subroutine calc_rt(debug, isp, lwin, ltrp, ts, sfc_emis, psfc, * tp, taup, tcold, rclr_s, rclr_s2, csrbs, * scene_type, lat, shifted_FM_opt, beta, delr, ra, * rwarm, rclr) c!F77------------------------------------------------------------------- c!Description: Calculate radiative transfer parameters for performing c CO2-slicing retrieval. c c!Input parameters: c debug Debug write flag c isp Level (1-101) of surface pressure c lwin Level of IRW cloud top pressure retrieval c ltrp Level (1-101) of tropopause c ts Surface temperature c sfc_emis Estimate of surface emissivity c psfc Surface pressure c tp Temperature profile c taup Transmittance profiles c rclr_s 11 micron radiance profile corresponding to 'ttpp' c rclr_s2 12 micron radiance profile corresponding to 'ttpp' c csrbs Mean monthly zonal clear sky radiance biases (CSRBs) c scene_type Scene type index (1=ocean, 2=AN land, 3=DN land) c lat Latitude of current HIRS FOV c shifted_FM_opt shifted/unshifted forward model option c 1=unshifted (original), 2=shifted FM and Planck c coefficients c c!Output parameters: c beta Beta ratio (11/12 microns) c delr LHS of CO2-slicing equation c ra RHS of CO2-slicing equation c rwarm Calculated clear-sky radiance for use in CO2-slicing c rclr Same as 'rwarm' but includes bands 11 and 12 c c!Revision history: c 07/10 R. Frey Original version c 01/11 R. Frey Added 'rclr' to argument list c Added calculation of clear-sky c radiances for bands 11 and 12; c stored in 'rclr' c 06/11 R. Frey Added 'csrbs', 'scene_type', 'lat' c Added CSRB use c 07/11 R. Frey Added 'shifted_FM_opt' c c c!Calls: c function fmrad_emis c function rf_hirsplanck c c!End------------------------------------------------------------------- implicit none save integer plev parameter (plev = 101) integer nbct parameter (nbct = 5) integer ntbct parameter (ntbct = 8) c Scalar arguments. integer debug, isp, lwin, ltrp, mid_px, mid_ln, scene_type, * shifted_FM_opt real ts, psfc, beta, lat c Array arguments. real tp(plev), taup(plev,ntbct), tcold(ntbct), rclr_s(plev), * rclr_s2(plev), delr(nbct), ra(plev,nbct), * sfc_emis(ntbct), rwarm(nbct), rclr(ntbct), * csrbs(180, 8, 3) c Local scalars. integer ii, is1, k, ll, beta_lev, mbnds(ntbct), ilat real sum, db, robs11, robs12, ne11, ne12 c Local arrays. real bias(nbct), robs(nbct), pp(plev) c External functions. real rf_hirsplanck, fmrad_emis external rf_hirsplanck, fmrad_emis c----------------------------------------------------------------------- c Define 101 pressure levels. data pp / 0.0050, 0.0161, 0.0384, 0.0769, 0.1370, + 0.2244, 0.3454, 0.5064, 0.7140, 0.9753, 1.2972, + 1.6872, 2.1526, 2.7009, 3.3398, 4.0770, 4.9204, + 5.8776, 6.9567, 8.1655, 9.5119, 11.0038, 12.6492, + 14.4559, 16.4318, 18.5847, 20.9224, 23.4526, 26.1829, + 29.1210, 32.2744, 35.6505, 39.2566, 43.1001, 47.1882, + 51.5278, 56.1260, 60.9895, 66.1253, 71.5398, 77.2396, + 83.2310, 89.5204, 96.1138, 103.0172, 110.2366, 117.7775, + 125.6456, 133.8462, 142.3848, 151.2664, 160.4959, 170.0784, + 180.0183, 190.3203, 200.9887, 212.0277, 223.4415, 235.2338, + 247.4085, 259.9691, 272.9191, 286.2617, 300.0000, 314.1369, + 328.6753, 343.6176, 358.9665, 374.7241, 390.8926, 407.4738, + 424.4698, 441.8819, 459.7118, 477.9607, 496.6298, 515.7200, + 535.2322, 555.1669, 575.5248, 596.3062, 617.5112, 639.1398, + 661.1920, 683.6673, 706.5654, 729.8857, 753.6275, 777.7897, + 802.3714, 827.3713, 852.7880, 878.6201, 904.8659, 931.5236, + 958.5911, 986.0666, 1013.9476, 1042.2319, 1070.9170, 1100.0000/ c Order of HIRS IR band numbers used data mbnds/4,5,6,7,8,10,11,12/ c----------------------------------------------------------------------- c Perform radiative transfer calculations for co2-slicing method. c----------------------------------------------------------------------- c Define index of first level of integration in computing RHS of c co2-slicing equation. is1 = isp - 1 c Compute TOA clear radiance from input profiles. do k = 1,ntbct rclr(k) = fmrad_emis(ts,sfc_emis(k),psfc,pp,tp,taup(1,k), & mbnds(k),isp, shifted_FM_opt) enddo c Compute components of RHS do k = 1, nbct sum = 0.0 do ll = is1,1,-1 db = rf_hirsplanck(tp(ll + 1),mbnds(k), shifted_FM_opt) & - rf_hirsplanck(tp(ll),mbnds(k), shifted_FM_opt) sum = sum - 0.5 * (taup(ll + 1,k) + taup(ll,k)) * db ra(ll,k) = sum enddo enddo c----------------------------------------------------------------------- c Apply clear-sky radiance bias corrections and calculate spectral c cloud forcing. c Find latitude zone for current HIRS FOV. ilat = min( max( (int(90.0 - lat) + 1), 1), 180) do k = 1, nbct c Get bias correction for this channel bias(k) = csrbs(ilat,k,scene_type) c Apply clear-sky radiance bias correction. if( (k .ne. nbct) .and. (bias(k) .ne. -999.0) ) then rwarm(k) = rclr(k) + bias(k) else c No correction is available. rwarm(k) = rclr(k) end if c Get "cold" or "cloudy" radiance from observations. robs(k) = rf_hirsplanck(tcold(k),mbnds(k), 1) c Calculate "cold - warm" or "clear - cloudy" value. These are c components of the LHS of the co2-slicing equation. delr(k) = robs(k) - rwarm(k) enddo c----------------------------------------------------------------------- c Compute Beta ratio. beta_lev = (lwin + ltrp) / 2 robs11 = rf_hirsplanck(tcold(5),8, 1) robs12 = rf_hirsplanck(tcold(6),10, 1) ne11 = (robs11 - rclr_s(isp)) / (rclr_s(beta_lev) - rclr_s(isp)) ne12 = (robs12 - rclr_s2(isp)) / (rclr_s2(beta_lev) - rclr_s2(isp)) if(ne11 .le. 1.0 .and. ne12 .le. 1.0) then beta = log(1.0 - ne12) / log(1.0 - ne11) else beta = 999.9 end if c ... ----------------------------------------------------------------- c ... Write debug information for radiative transfer calculations. if(debug .gt. 0) then write(*,'(/,''Radiative transfer section in calc_rt'')') write(*,'(''Surface temperature '',f10.3)') ts write(*,'(''Trop level and beta ratio '',i5,f10.3)') & ltrp, beta write(*,'(''Latitude and zone index for CSRBs '', f8.2,i5)') lat, ilat write(*,'(''Values for HIRS bands '',5i10)') & (mbnds(ii),ii=1,nbct) write(*,'(''Calculated TOA radiances '',5f10.3)') & (rclr(ii),ii=1,nbct) write(*,'(''Clear-sky radiance bias '',5f10.3)') & (bias(ii),ii=1,nbct) write(*,'(''Warm or clear radiances '',5f10.3)') & (rwarm(ii),ii=1,nbct) write(*,'(''Cold or cloudy radiances '',5f10.3)') & (robs(ii),ii=1,nbct) write(*,'(''Spectral cloud forcing '',5f10.3)') & (delr(ii),ii=1,nbct) write(*,'(1x)') end if c----------------------------------------------------------------------- return end