subroutine rf_hirstran_101(debug,year,jday,temp,wvmr,ozmr,theta, & craft,kan,shifted_FM_opt,taut) ! * Modified by R. Frey for use in MODIS-like CTP retrieval algorithm. ! * HIRS/2,/3,/4 dry/wet/ozo transmittance ! .... version of 16.07.08 ! * LarrabeeStrow/HalWoolf/PaulVanDelst regression model based on ! * LBLRTM line-by-line transmittances. ! * Input temperatures, and water-vapor and ozone mixing ratios, must ! * be defined at the 101 pressure levels in array 'pstd' (see block ! * data 'reference_atmosphere' in file 'irtsubn101.f'). ! * Units: temperature, deg-K; water vapor, g/kg; ozone, ppmv. ! * Logical unit numbers 71-75 are used for coefficient files. ! * Input ! debug = debug write index ................. 0-3 ! year = data year ......................... yyyy ! jday = day of year ....................... ddd ! temp = profile of temperature ............ degK ! wvmr = profile of H2O mixing ratio ....... g/kg ! ozmr = profile of O3 mixing ratio ....... ppmv ! theta = local zenith angle ................ deg ! craft = spacecraft, upper or lower case ... tirosn,noaa06,...,noaa18,metopa ! kan = channel number .................... 1 - 19 ! * Output ! taut = profile of total transmittance (components are returned through common) ! * = error return in case of coefficient-file I/O trouble integer lfac, nk, nl, nm, nr parameter (lfac=4,nk=5,nl=101,nm=nl-1,nr=19) integer nxc, ncc, lencc, lenccb parameter (nxc= 4,ncc=nxc+1,lencc=ncc*nm,lenccb=lencc*lfac) integer nxd, ncd, lencd, lencdb parameter (nxd= 8,ncd=nxd+1,lencd=ncd*nm,lencdb=lencd*lfac) integer nxo, nco, lenco, lencob parameter (nxo= 9,nco=nxo+1,lenco=nco*nm,lencob=lenco*lfac) integer nxl, ncl, lencl, lenclb parameter (nxl= 2,ncl=nxl+1,lencl=ncl*nm,lenclb=lencl*lfac) integer nxs, ncs, lencs, lencsb parameter (nxs=11,ncs=nxs+1,lencs=ncs*nm,lencsb=lencs*lfac) integer nxw parameter (nxw=nxl+nxs) c Parameters for calculation of variable CO2 concentration adjustment to 'taud'. c R. Frey real slp parameter (slp = 1.5 / 365.0) real smag parameter (smag = 3.0) real soff parameter (soff = 0.41) real coff parameter (coff = 337.5) real pi parameter (pi = 3.14159) real temp, wvmr, ozmr, taut, pstd, tstd, wstd, ostd, taud, tauw, tauo, & coefd, coefo, coefc, coefl, coefs, pavg, tref, wref, oref, tavg, tauc, & wamt, oamt, secz, tau, tlas, wlas, olas, xdry, xozo, xcon, xwet, zlas, & theta, secant, z, dt, dw, do, datm, zsec integer iuc, lencf, kan, noff, koff, iux, l, k, krec, i, j, jj, shifted_FM_opt common/stdatm/pstd(nl),tstd(nl),wstd(nl),ostd(nl) common/taudwo/taud(nl),tauw(nl),tauo(nl) dimension temp(101),wvmr(101),ozmr(101),taut(101) dimension coefd(ncd,nm,nr),coefo(nco,nm,nr),coefc(ncc,nm,nr) dimension coefl(ncl,nm,nr),coefs(ncs,nm,nr),iuc(nk),lencf(nk) dimension pavg(nm),tref(nm),wref(nm),oref(nm) dimension tavg(nm),wamt(nm),oamt(nm),secz(nm) dimension tauc(nl),tlas(nl),wlas(nl),olas(nl) dimension xdry(nxd,nm),xozo(nxo,nm),xcon(nxc,nm),xwet(nxw,nm) character*17 cfile, cfile_shft, cfile_orig character*6 craft,clast character*3 comp(nk),csat real*4 x,ratio,rco2,tau_test integer*4 debug,year,jday logical newang,newatm data cfile_orig/'hirsccom_orig.dat'/ data cfile_shft/'hirsccom_shft.dat'/ data clast/'999999'/ data comp/'dry','ozo','wco','wtl','wts'/ data lencf/lencdb,lencob,lenccb,lenclb,lencsb/ data tlas/nl*0./,wlas/nl*0./,olas/nl*0./,zlas/-999./ secant(z)=1./cos(0.01745329*z) if(shifted_FM_opt .eq. 2) then cfile = cfile_shft else cfile = cfile_orig end if if(craft.ne.clast) then call getallsc(craft,csat,noff) koff=noff*nr ! * define and open the coefficient files iux=70 do l=1,nk cfile(6:8)=comp(l) write(*,'(/,''coeff file '',2a20)') cfile,craft iux=iux+1 open(iux,file=cfile,recl=lencf(l),access='direct', + status='old',err=200) iuc(l)=iux enddo ! * read in coefficients do k=1,nr krec=k+koff read(iuc(1),rec=krec) ((coefd(i,j,k),i=1,ncd),j=1,nm) read(iuc(2),rec=krec) ((coefo(i,j,k),i=1,nco),j=1,nm) read(iuc(3),rec=krec) ((coefc(i,j,k),i=1,ncc),j=1,nm) read(iuc(4),rec=krec) ((coefl(i,j,k),i=1,ncl),j=1,nm) read(iuc(5),rec=krec) ((coefs(i,j,k),i=1,ncs),j=1,nm) enddo do l=1,nk close(iuc(l)) enddo call conpir(pstd,tstd,wstd,ostd,nl,1,pavg,tref,wref,oref) clast=craft endif do j=1,nl taud(j)=1.0 tauw(j)=1.0 tauc(j)=1.0 tauo(j)=1.0 taut(j)=1.0 enddo dt=0. dw=0. do=0. do j=1,nl dt=dt+abs(temp(j)-tlas(j)) tlas(j)=temp(j) dw=dw+abs(wvmr(j)-wlas(j)) wlas(j)=wvmr(j) do=do+abs(ozmr(j)-olas(j)) olas(j)=ozmr(j) enddo datm=dt+dw+do newatm=datm.ne.0. if(newatm) then call conpir(pstd,temp,wvmr,ozmr,nl,1,pavg,tavg,wamt,oamt) endif newang=theta.ne.zlas if(newang) then zsec=secant(theta) do l=1,nm secz(l)=zsec enddo zlas=theta endif if(newang.or.newatm) then call calpir(tref,wref,oref,tavg,wamt,oamt,pavg,secz, + nm,nxd,nxw,nxo,nxc,xdry,xwet,xozo,xcon) endif k=kan ! * dry call taudoc(ncd,nxd,nm,coefd(1,1,k),xdry,taud) c Adjust dry tau for changes in CO2 concentration from model (R. Frey) x = (year - 1980) * 365.25 + jday rco2 = (slp*x - smag*sin(2*pi*(x/365.25 + soff))) + coff if(rco2.ne.380.) then ratio=rco2/380.0 do jj=1,nl tau_test = taud(jj) if(taud(jj).gt.0.0 .and. taud(jj).lt.1.0) then taud(jj)=taud(jj)**ratio if(debug .gt. 2) then write(*,'(''dry tau adj. '',2i4,5f10.4)') kan,jj,x,rco2,ratio,tau_test,taud(jj) end if endif enddo endif ! * ozo call taudoc(nco,nxo,nm,coefo(1,1,k),xozo,tauo) ! * wet ! .... continuum call taudoc(ncc,nxc,nm,coefc(1,1,k),xcon,tauc) ! .... lines call tauwtr(ncs,ncl,nxs,nxl,nxw,nm,coefs(1,1,k), + coefl(1,1,k),xwet,tauw) ! .... total water vapor do j=1,nl tauw(j)=tauw(j)*tauc(j) enddo ! * total transmittance do j=1,nl taut(j)=taud(j)*tauo(j)*tauw(j) enddo return 200 return end