subroutine reflam(ichan,iofset,ilat,xlat,isnow, 1 pcloud,pteran,estozn,xnvalm,ramcor,fteran, 2 lprint,clfrac,ref,iloprf,ihiprf,dndr) c c*********************************************************************** c c reflam c c august, 2001 by charlie wellemeyer of ssai c c purpose c compute cloud fraction, reflectivity, and dndr for c monochromator wavelengths running from 292 to 340. c c method c establish assumed ground and cloud reflectivities. c select interpolation indices for table lookup. c perform table interpolations in pressure and ozone, c then calculate cloud fraction. c calculate reflectivity by inverting the surface c radiance formula for clear or completly cloudy, and c use the partial cloud model for partly clouded scenes. c c variables c name type i/o description c ---- ---- --- ----------- c arguments c ichan i*4 i channel index for calculation c iofset i*4 i offset pointer. c ilat i*4 i latitude index (1 - low 2 - mid 3 - high) c xlat i*4 i latitude c isnow i*4 i snow/ice indicator c pcloud r*4 i cloud top pressure c pteran r*4 i terrain pressure c estozn r*4 i current total ozone estimate c xnvalm r*4 i monochromator measured n-values c ramcor r*4 i raman scattering correction c fteran r*4 i interpolation fraction for terrain pressure c lprint l*4 i if = .true., print c clfrac r*4 o cloud fraction c ref r*4 o reflectivity for wavelength ichan c iloprf i*4 i/o profile index at low bound c ihiprf i*4 i/o profile index at high bound c dndr r*4 o refl sensitivity of mono at channel ichan c grref r*4 o ground reflectivity c internal c clref r*4 cloud reflectivity c pref r*4 perturbed ref (needed for dN/dR calculation) c pcfrac r*4 perturbed cloud frac(needed for dN/dR calculation) c c*********************************************************************** c implicit none c -- input parameters real xlat, pcloud, pteran, estozn, xnvalm(12), fteran real ramcor(9,6) integer ichan, iofset(12), ilat, isnow , iloprf, ihiprf logical lprint(30) c -- internal parameters real cnvrt/0.017453/ real ezero, t, qgclc(4), qcclc(4), qsavlo, qsavhi real alb, den, fteran, oznind, pxnvalm, pxnvalp, palb real ezlggr, tloggr, sbgrnd, ezlgcl, tlogcl, sbcld real grad, crad, pden, pref, pgref, pcref, grref, clref real pgrref, pcfrac, pclref real omeglo, omeghi, ozfrac, rmcrgr, rmcrcl real ezgr(2),ssgr(2),tgr(2),sbgr(2),ezcl(2),sscl(2), 1 tcl(2),sbcl(2),radgr(2),radcl(2),qgcalc(2),qccalc(2),sb integer iprfl, ioz c -- output parameters real clfrac, pgrref, pclref, pcfrac, ref, dndr c -- common area and data statements include 'stndprof.com' c c -- convert reflectivity channel n value to albedo c alb = 10.**(-xnvalm(ichan)) c c -- initialize ground and cloud reflectivities c call prflec(pteran,pcloud,lprint,grref,clref) c if (lprint(11)) then write (6,1000) xlat, isnow, iofset(ichan), grref, 1 clref, ichan, pcloud, pteran, alb, ilat, 2 estozn, fteran, ramcor endif c c -- perturb measured reflectivity channel n value by 0.1% c -- all varaibles beginning with p are from perturbed n value c -- (needed for dN/dR calculation) c pxnvalm = 1.002*xnvalm(ichan) palb = 10.**(-pxnvalm) pgrref = grref pclref = clref c c -- use profile indeces determined by calling routine c iprfl = iloprf - 2 c c -- do two calculations for bracketting ozone profiles c do ioz=1,2 iprfl = iprfl + 1 c c -- compute i0, tr, and sb values c call iztrsb(ichan,xlat,iprfl,pteran,pcloud, 1 iofset(ichan),lprint,ezgr(ioz),ssgr(ioz),tgr(ioz), 2 sbgr(ioz),ezcl(ioz),sscl(ioz),tcl(ioz),sbcl(ioz)) c enddo c c -- compute delta ozone including terrain height corrections c omeglo = profl(iloprf) - terroz(iloprf)*fteran omeghi = profl(ihiprf) - terroz(ihiprf)*fteran ozfrac = (estozn-omeglo)/(omeghi-omeglo) c c -- calculate raman corrections for ground and cloud c call getrng(ichan,pteran,pcloud,grref,clref,ramcor,lprint, 1 rmcrgr,rmcrcl) c c -- Interpolate log of table parameters to current ozone estimate c -- and convert to radiance for cloud fraction calculation c ezlggr=alog10(ezgr(1))+alog10(ezgr(2)/ezgr(1))*ozfrac tloggr=alog10(tgr(1))+alog10(tgr(2)/tgr(1))*ozfrac sbgrnd=sbgr(1)+(sbgr(2)-sbgr(1))*ozfrac grad=10.0**ezlggr+grref*10.0**tloggr/(1.0-grref*sbgrnd) grad = grad + grad * rmcrgr c ezlgcl=alog10(ezcl(1))+alog10(ezcl(2)/ezcl(1))*ozfrac tlogcl=alog10(tcl(1))+alog10(tcl(2)/tcl(1))*ozfrac sbcld=sbcl(1)+(sbcl(2)-sbcl(1))*ozfrac crad=10.0**ezlgcl+clref*10.0**tlogcl/(1.0-clref*sbcld) crad = crad + crad * rmcrcl c c -- Calculate cloud fraction c if (crad-grad.ne.0.) then clfrac = (alb-grad) / (crad-grad) pcfrac = (palb-grad) / (crad-grad) else clfrac = 0. pcfrac = 0. endif c c assume clear sky if snow is present c c if(isnow.eq.10) clfrac = 0.0 if(isnow.ge.5) clfrac = 0.0 c c -- calculate reflectivity using version 6 method for cloud free c if (clfrac.le.0.0d0) then den = alb - 10.0**(ezlggr) pden = palb - 10.0**(ezlggr) if (den.ne.0.) then ref = 1. / (10.0**(tloggr)/den + sbgrnd) else ref = 0. endif if (pden.ne.0.) then pref = 1. / (10.0**(tloggr)/pden + sbgrnd) else pref = 0. endif clfrac = 0.0 pcfrac = 0.0 grref = ref pgref = pref c c -- calculate reflectivity using version 6 method for cloudy case c else if (clfrac.ge.1.0d0) then den = alb - 10.0**(ezlgcl) pden = palb - 10.0**(ezlgcl) if (den.ne.0.) then ref = 1. / (10.0**(tlogcl)/den + sbcld) else ref = 0. endif if (pden.ne.0.) then pref = 1. / (10.0**(tlogcl)/pden + sbcld) else pref = 0. endif clfrac = 1.0 pcfrac = 1.0 clref = ref pcref = pref c c -- calculate reflectivity using cloud fraction and nominal refls c else ref = grref + clfrac*(clref-grref) pref = pgrref + pcfrac*(pclref-pgrref) c endif c dndr = (pxnvalm-xnvalm(ichan))/(pref-ref) c if (lprint(11)) write (6,1300) pcfrac,pref,clfrac,ref c return c c -- format statements c 1000 format (/'Subroutine reflam'/'Input: ','xlat = ',f8.3, 1 ' isnow = ',i8,' iofset = ',i8/ 2 ' grref = ',f8.4,' clref = ',f8.4,' ichan = ',i8/ 3 ' pcloud = ',f8.4,' pteran = ',f8.4,' alb = ',f8.4,/, 4 ' ilat = ',i3,/, 5 ' estozn = ',f7.1,' fteran = ',f6.3,/, 7 ' ramcor = ',6(/8f8.3)) 1200 format ('Final: qgcalc = ',f8.6,' qccalc = ',f8.6, 1 ' den = ',f8.4) 1300 format ('Output: pcfrac = ',f8.4, 1 ' pref = ',f8.5,/, 2 9x,'clfrac = ',f8.4,' ref = ',f8.5) c end