<p><b>laura@ucar.edu</b> 2011-05-20 10:44:36 -0600 (Fri, 20 May 2011)</p><p>added modules needed for CAM radiation parameterizations<br>
</p><hr noshade><pre><font color="gray">Added: branches/atmos_physics/src/core_physics/physics_wrf/module_cam_shr_kind_mod.F
===================================================================
--- branches/atmos_physics/src/core_physics/physics_wrf/module_cam_shr_kind_mod.F (rev 0)
+++ branches/atmos_physics/src/core_physics/physics_wrf/module_cam_shr_kind_mod.F 2011-05-20 16:44:36 UTC (rev 849)
@@ -0,0 +1,26 @@
+!------------------------------------------------------------------------
+! Based on csm_share/shr/shr_kind_mod.F90 from CAM
+! Ported to WRF by William.Gustafson@pnl.gov, Nov. 2009
+!------------------------------------------------------------------------
+!===============================================================================
+! SVN $Id: shr_kind_mod.F90 11926 2008-09-25 21:10:40Z mvertens $
+! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/branch_tags/cesm1_0_rel_tags/cesm1_0_rel03_share3_100802/shr/shr_kind_mod.F90 $
+!===============================================================================
+
+MODULE shr_kind_mod
+
+ !----------------------------------------------------------------------------
+ ! precision/kind constants add data public
+ !----------------------------------------------------------------------------
+ public
+ integer,parameter :: SHR_KIND_R8 = selected_real_kind(12) ! 8 byte real
+ integer,parameter :: SHR_KIND_R4 = selected_real_kind( 6) ! 4 byte real
+ integer,parameter :: SHR_KIND_RN = kind(1.0) ! native real
+ integer,parameter :: SHR_KIND_I8 = selected_int_kind (13) ! 8 byte integer
+ integer,parameter :: SHR_KIND_I4 = selected_int_kind ( 6) ! 4 byte integer
+ integer,parameter :: SHR_KIND_IN = kind(1) ! native integer
+ integer,parameter :: SHR_KIND_CS = 80 ! short char
+ integer,parameter :: SHR_KIND_CL = 256 ! long char
+ integer,parameter :: SHR_KIND_CX = 512 ! extra-long char
+
+END MODULE shr_kind_mod
Added: branches/atmos_physics/src/core_physics/physics_wrf/module_cam_support.F
===================================================================
--- branches/atmos_physics/src/core_physics/physics_wrf/module_cam_support.F (rev 0)
+++ branches/atmos_physics/src/core_physics/physics_wrf/module_cam_support.F 2011-05-20 16:44:36 UTC (rev 849)
@@ -0,0 +1,206 @@
+MODULE module_cam_support
+!------------------------------------------------------------------------
+! This module contains global scope variables and routines shared by
+! multiple CAM physics routines. As much as possible, the codes is copied
+! verbatim from the corresponding CAM modules noted below.
+!
+! Author: William.Gustafson@pnl.gov, Nov 2009
+!------------------------------------------------------------------------
+#if (defined(non_hydrostatic_core) || defined(hydrostatic_core))
+ use module_physics_utilities
+#else
+ use module_state_description, only: param_num_moist
+#endif
+ use shr_kind_mod
+
+ implicit none
+
+ public
+ save
+
+ integer(SHR_KIND_IN),parameter,private :: R8 = SHR_KIND_R8 ! rename for local readability only
+
+! From spmd_utils in CAM...
+ logical, parameter :: masterproc = .true.
+
+! From ppgrid in CAM...
+ integer, parameter :: pcols = 1 !Always have a chunk size of 1 in WRF
+ integer :: pver !Number of model level middles in CAM speak
+ integer :: pverp !Number of model level interfaces in CAM speak
+
+
+! From constituents in CAM...
+#if (defined(non_hydrostatic_core) || defined(hydrostatic_core))
+ real(kind=r8),dimension(:),allocatable :: qmin !Minimun constituent concentration. note that
+ !qmin is never used in module_ra_cam_support.
+ !Laura D. Fowler (05-19-2011).
+#else
+ integer, parameter :: pcnst = param_num_moist !Number of tracer constituents for CAM q array
+ !In WRF this is currently setup to only handle
+ !the moist array, and then even in a half-handed way.
+ !We allocate the max possible size, but loops need to
+ !be over a smaller number.
+ !Scalar and chem need to eventually be handled too.
+ real(kind=r8), parameter, dimension(pcnst) :: qmin = 0. !Minimun constituent concentration
+ !(kg/kg) Normally 0.
+#endif
+
+! From cam_logfile...
+ character(len=250) :: iulog !In CAM this is a file handle. In WRF, this is a string
+ !that can be used to send messages via wrf_message, etc.
+
+!From cam_pio_utils.F90
+integer, parameter, public :: phys_decomp=100
+
+! From cam_pio_utils (used in camuwpbl_driver module)...
+integer, parameter :: fieldname_len = 16 ! max chars for field name
+
+!------------------------------------------------------------------------
+CONTAINS
+!------------------------------------------------------------------------
+
+!!$!------------------------------------------------------------------------
+!!$CHARACTER(len=3) FUNCTION cnst_get_type_byind(ind)
+!!$! Gets the consituent type.
+!!$!
+!!$! Replaces function of same name in constituents module in CAM.
+!!$! ~This routine is currently hard-coded for the indices. It should be
+!!$! generalized to handle arbitrary values, especially for chemical
+!!$! tracers and advanced microphysics with additional phases.
+!!$!
+!!$! Author: William.Gustafson@pnl.gov, Nov 2009
+!!$!------------------------------------------------------------------------
+!!$ integer, intent(in) :: ind !global constituent index (in q array)
+!!$
+!!$ select case (ind)
+!!$
+!!$ case(1) !vapor
+!!$ cnst_get_type_byind = "wet"
+!!$ case (2) !cloud droplets
+!!$ cnst_get_type_byind = "wet"
+!!$ case (3) !cloud ice crystals
+!!$ cnst_get_type_byind = "wet"
+!!$ case default
+!!$ cnst_get_type_byind = "wet"
+!!$ end select
+!!$
+!!$END FUNCTION cnst_get_type_byind
+
+
+#if (defined(non_hydrostatic_core) || defined(hydrostatic_core))
+!------------------------------------------------------------------------
+SUBROUTINE endrun(msg)
+! Pass through routine to wrf_error_fatal that mimics endrun in module
+! abortutils of CAM.
+!
+! Replaces endrun in abortutils module in CAM.
+!
+! Author: William.Gustafson@pnl.gov, Nov 2009
+! Modified : Balwinder.Singh@pnl.gov - Argument made optional
+!------------------------------------------------------------------------
+! Argument of the subroutine is made optional to accomodate endrun calls with no argument
+ character(len=*), intent(in), optional :: msg
+
+ if(present(msg)) then
+ call physics_error_fatal(msg)
+ else
+! The error message is written to iulog bwfore the endrun call
+ call physics_error_fatal(iulog)
+ endif
+END SUBROUTINE endrun
+#else
+!------------------------------------------------------------------------
+SUBROUTINE endrun(msg)
+! Pass through routine to wrf_error_fatal that mimics endrun in module
+! abortutils of CAM.
+!
+! Replaces endrun in abortutils module in CAM.
+!
+! Author: William.Gustafson@pnl.gov, Nov 2009
+! Modified : Balwinder.Singh@pnl.gov - Argument made optional
+!------------------------------------------------------------------------
+ USE module_wrf_error
+
+! Argument of the subroutine is made optional to accomodate endrun calls with no argument
+ character(len=*), intent(in), optional :: msg
+
+ if(present(msg)) then
+ call wrf_error_fatal(msg)
+ else
+! The error message is written to iulog bwfore the endrun call
+ call wrf_error_fatal(iulog)
+ endif
+END SUBROUTINE endrun
+#endif
+
+
+!------------------------------------------------------------------------
+SUBROUTINE t_stopf(event)
+! Stub to accomodate stop time calls of CAM
+!
+! Replaces t_stopf in perf_mod module in CAM.
+!
+! Author: Balwinder.Singh@pnl.gov
+!------------------------------------------------------------------------
+ character(len=*), intent(in) :: event
+
+END SUBROUTINE t_stopf
+
+
+
+!------------------------------------------------------------------------
+SUBROUTINE t_startf(event)
+! Stub to accomodate start time calls of CAM
+!
+! Replaces t_startf in perf_mod module in CAM.
+!
+! Author: Balwinder.Singh@pnl.gov
+!------------------------------------------------------------------------
+
+ character(len=*), intent(in) :: event
+
+ END SUBROUTINE t_startf
+
+
+
+!------------------------------------------------------------------------
+SUBROUTINE outfld( fname, field, idim, c)
+! Stub to accomodate outfld calls of CAM
+!
+! Replaces outfld in cam_history module in CAM.
+!
+! Author: Balwinder.Singh@pnl.gov
+!------------------------------------------------------------------------
+ character(len=*), intent(in) :: fname
+ integer, intent(in) :: idim
+ integer, intent(in) :: c
+ real(r8), intent(in) :: field(idim,*)
+
+END SUBROUTINE outfld
+
+
+
+!------------------------------------------------------------------------
+SUBROUTINE addfld(fname, units, numlev, avgflag, long_name, &
+ decomp_type, flag_xyfill, flag_isccplev, sampling_seq)
+! Stub to accomodate addfld calls of CAM
+!
+! Replaces addfld in cam_history module in CAM.
+!
+! Author: Balwinder.Singh@pnl.gov
+!------------------------------------------------------------------------
+ character(len=*), intent(in) :: fname
+ character(len=*), intent(in) :: units
+ character(len=1), intent(in) :: avgflag
+ character(len=*), intent(in) :: long_name
+
+ integer, intent(in) :: numlev
+ integer, intent(in) :: decomp_type
+
+ logical, intent(in), optional :: flag_xyfill
+ logical, intent(in), optional :: flag_isccplev
+ character(len=*), intent(in), optional :: sampling_seq
+
+END SUBROUTINE ADDFLD
+
+END MODULE module_cam_support
Added: branches/atmos_physics/src/core_physics/physics_wrf/module_ra_cam.F
===================================================================
--- branches/atmos_physics/src/core_physics/physics_wrf/module_ra_cam.F (rev 0)
+++ branches/atmos_physics/src/core_physics/physics_wrf/module_ra_cam.F 2011-05-20 16:44:36 UTC (rev 849)
@@ -0,0 +1,7876 @@
+MODULE module_ra_cam
+ use module_ra_cam_support
+ use module_cam_support, only: endrun
+
+ implicit none
+!
+! A. Slingo's data for cloud particle radiative properties (from 'A GCM
+! Parameterization for the Shortwave Properties of Water Clouds' JAS
+! vol. 46 may 1989 pp 1419-1427)
+!
+ real(r8) abarl(4) ! A coefficient for extinction optical depth
+ real(r8) bbarl(4) ! B coefficient for extinction optical depth
+ real(r8) cbarl(4) ! C coefficient for single scat albedo
+ real(r8) dbarl(4) ! D coefficient for single scat albedo
+ real(r8) ebarl(4) ! E coefficient for asymmetry parameter
+ real(r8) fbarl(4) ! F coefficient for asymmetry parameter
+
+ save abarl, bbarl, cbarl, dbarl, ebarl, fbarl
+
+ data abarl/ 2.817e-02, 2.682e-02,2.264e-02,1.281e-02/
+ data bbarl/ 1.305 , 1.346 ,1.454 ,1.641 /
+ data cbarl/-5.62e-08 ,-6.94e-06 ,4.64e-04 ,0.201 /
+ data dbarl/ 1.63e-07 , 2.35e-05 ,1.24e-03 ,7.56e-03 /
+ data ebarl/ 0.829 , 0.794 ,0.754 ,0.826 /
+ data fbarl/ 2.482e-03, 4.226e-03,6.560e-03,4.353e-03/
+
+#if 0
+! moved and changed to local variables into radcswmx for thread-safety, JM 20100217
+ real(r8) abarli ! A coefficient for current spectral band
+ real(r8) bbarli ! B coefficient for current spectral band
+ real(r8) cbarli ! C coefficient for current spectral band
+ real(r8) dbarli ! D coefficient for current spectral band
+ real(r8) ebarli ! E coefficient for current spectral band
+ real(r8) fbarli ! F coefficient for current spectral band
+#endif
+!
+! Caution... A. Slingo recommends no less than 4.0 micro-meters nor
+! greater than 20 micro-meters
+!
+! ice water coefficients (Ebert and Curry,1992, JGR, 97, 3831-3836)
+!
+ real(r8) abari(4) ! a coefficient for extinction optical depth
+ real(r8) bbari(4) ! b coefficient for extinction optical depth
+ real(r8) cbari(4) ! c coefficient for single scat albedo
+ real(r8) dbari(4) ! d coefficient for single scat albedo
+ real(r8) ebari(4) ! e coefficient for asymmetry parameter
+ real(r8) fbari(4) ! f coefficient for asymmetry parameter
+
+ save abari, bbari, cbari, dbari, ebari, fbari
+
+ data abari/ 3.448e-03, 3.448e-03,3.448e-03,3.448e-03/
+ data bbari/ 2.431 , 2.431 ,2.431 ,2.431 /
+ data cbari/ 1.00e-05 , 1.10e-04 ,1.861e-02,.46658 /
+ data dbari/ 0.0 , 1.405e-05,8.328e-04,2.05e-05 /
+ data ebari/ 0.7661 , 0.7730 ,0.794 ,0.9595 /
+ data fbari/ 5.851e-04, 5.665e-04,7.267e-04,1.076e-04/
+
+#if 0
+! moved and changed to local variables into radcswmx for thread-safety, JM 20100217
+ real(r8) abarii ! A coefficient for current spectral band
+ real(r8) bbarii ! B coefficient for current spectral band
+ real(r8) cbarii ! C coefficient for current spectral band
+ real(r8) dbarii ! D coefficient for current spectral band
+ real(r8) ebarii ! E coefficient for current spectral band
+ real(r8) fbarii ! F coefficient for current spectral band
+#endif
+!
+ real(r8) delta ! Pressure (in atm) for stratos. h2o limit
+ real(r8) o2mmr ! O2 mass mixing ratio:
+
+ save delta, o2mmr
+
+!
+! UPDATE TO H2O NEAR-IR: Delta optimized for Hitran 2K and CKD 2.4
+!
+ data delta / 0.0014257179260883 /
+!
+! END UPDATE
+!
+ data o2mmr / .23143 /
+
+! Next series depends on spectral interval
+!
+ real(r8) frcsol(nspint) ! Fraction of solar flux in spectral interval
+ real(r8) wavmin(nspint) ! Min wavelength (micro-meters) of interval
+ real(r8) wavmax(nspint) ! Max wavelength (micro-meters) of interval
+ real(r8) raytau(nspint) ! Rayleigh scattering optical depth
+ real(r8) abh2o(nspint) ! Absorption coefficiant for h2o (cm2/g)
+ real(r8) abo3 (nspint) ! Absorption coefficiant for o3 (cm2/g)
+ real(r8) abco2(nspint) ! Absorption coefficiant for co2 (cm2/g)
+ real(r8) abo2 (nspint) ! Absorption coefficiant for o2 (cm2/g)
+ real(r8) ph2o(nspint) ! Weight of h2o in spectral interval
+ real(r8) pco2(nspint) ! Weight of co2 in spectral interval
+ real(r8) po2 (nspint) ! Weight of o2 in spectral interval
+ real(r8) nirwgt(nspint) ! Spectral Weights to simulate Nimbus-7 filter
+ save frcsol ,wavmin ,wavmax ,raytau ,abh2o ,abo3 , &
+ abco2 ,abo2 ,ph2o ,pco2 ,po2 ,nirwgt
+
+ data frcsol / .001488, .001389, .001290, .001686, .002877, &
+ .003869, .026336, .360739, .065392, .526861, &
+ .526861, .526861, .526861, .526861, .526861, &
+ .526861, .006239, .001834, .001834/
+!
+! weight for 0.64 - 0.7 microns appropriate to clear skies over oceans
+!
+ data nirwgt / 0.0, 0.0, 0.0, 0.0, 0.0, &
+ 0.0, 0.0, 0.0, 0.320518, 1.0, 1.0, &
+ 1.0, 1.0, 1.0, 1.0, 1.0, &
+ 1.0, 1.0, 1.0 /
+
+ data wavmin / .200, .245, .265, .275, .285, &
+ .295, .305, .350, .640, .700, .701, &
+ .701, .701, .701, .702, .702, &
+ 2.630, 4.160, 4.160/
+
+ data wavmax / .245, .265, .275, .285, .295, &
+ .305, .350, .640, .700, 5.000, 5.000, &
+ 5.000, 5.000, 5.000, 5.000, 5.000, &
+ 2.860, 4.550, 4.550/
+
+!
+! UPDATE TO H2O NEAR-IR: Rayleigh scattering optimized for Hitran 2K & CKD 2.4
+!
+ real(r8) v_raytau_35
+ real(r8) v_raytau_64
+ real(r8) v_abo3_35
+ real(r8) v_abo3_64
+ parameter( &
+ v_raytau_35 = 0.155208, &
+ v_raytau_64 = 0.0392, &
+ v_abo3_35 = 2.4058030e+01, &
+ v_abo3_64 = 2.210e+01 &
+ )
+
+ data raytau / 4.020, 2.180, 1.700, 1.450, 1.250, &
+ 1.085, 0.730, v_raytau_35, v_raytau_64, &
+ 0.02899756, 0.01356763, 0.00537341, &
+ 0.00228515, 0.00105028, 0.00046631, &
+ 0.00025734, &
+ .0001, .0001, .0001/
+!
+! END UPDATE
+!
+
+!
+! Absorption coefficients
+!
+!
+! UPDATE TO H2O NEAR-IR: abh2o optimized for Hitran 2K and CKD 2.4
+!
+ data abh2o / .000, .000, .000, .000, .000, &
+ .000, .000, .000, .000, &
+ 0.00256608, 0.06310504, 0.42287445, 2.45397941, &
+ 11.20070807, 47.66091389, 240.19010243, &
+ .000, .000, .000/
+!
+! END UPDATE
+!
+
+ data abo3 /5.370e+04, 13.080e+04, 9.292e+04, 4.530e+04, 1.616e+04, &
+ 4.441e+03, 1.775e+02, v_abo3_35, v_abo3_64, .000, &
+ .000, .000 , .000 , .000 , .000, &
+ .000, .000 , .000 , .000 /
+
+ data abco2 / .000, .000, .000, .000, .000, &
+ .000, .000, .000, .000, .000, &
+ .000, .000, .000, .000, .000, &
+ .000, .094, .196, 1.963/
+
+ data abo2 / .000, .000, .000, .000, .000, &
+ .000, .000, .000,1.11e-05,6.69e-05, &
+ .000, .000, .000, .000, .000, &
+ .000, .000, .000, .000/
+!
+! Spectral interval weights
+!
+ data ph2o / .000, .000, .000, .000, .000, &
+ .000, .000, .000, .000, .505, &
+ .210, .120, .070, .048, .029, &
+ .018, .000, .000, .000/
+
+ data pco2 / .000, .000, .000, .000, .000, &
+ .000, .000, .000, .000, .000, &
+ .000, .000, .000, .000, .000, &
+ .000, 1.000, .640, .360/
+
+ data po2 / .000, .000, .000, .000, .000, &
+ .000, .000, .000, 1.000, 1.000, &
+ .000, .000, .000, .000, .000, &
+ .000, .000, .000, .000/
+
+ real(r8) amo ! Molecular weight of ozone (g/mol)
+ save amo
+
+ data amo / 48.0000 /
+
+contains
+subroutine camrad(RTHRATENLW,RTHRATENSW, &
+ dolw,dosw, &
+ SWUPT,SWUPTC,SWDNT,SWDNTC, &
+ LWUPT,LWUPTC,LWDNT,LWDNTC, &
+ SWUPB,SWUPBC,SWDNB,SWDNBC, &
+ LWUPB,LWUPBC,LWDNB,LWDNBC, &
+ swcf,lwcf,olr,cemiss,taucldc,taucldi,coszr, &
+ GSW,GLW,XLAT,XLONG, &
+ ALBEDO,t_phy,TSK,EMISS, &
+ QV3D,QC3D,QR3D,QI3D,QS3D,QG3D, &
+ F_QV,F_QC,F_QR,F_QI,F_QS,F_QG, &
+ f_ice_phy,f_rain_phy, &
+ p_phy,p8w,z,pi_phy,rho_phy,dz8w, &
+ CLDFRA,XLAND,XICE,SNOW, &
+ ozmixm,pin0,levsiz,num_months, &
+ m_psp,m_psn,aerosolcp,aerosolcn,m_hybi0, &
+ cam_abs_dim1, cam_abs_dim2, &
+ paerlev,naer_c, &
+ GMT,JULDAY,JULIAN,YR,DT,XTIME,DECLIN,SOLCON, &
+ RADT,DEGRAD,n_cldadv, &
+ abstot_3d, absnxt_3d, emstot_3d, &
+ doabsems, &
+ ids,ide, jds,jde, kds,kde, &
+ ims,ime, jms,jme, kms,kme, &
+ its,ite, jts,jte, kts,kte )
+
+#if (defined(non_hydrostatic_core) || defined(hydrostatic_core))
+ USE module_physics_utilities
+#else
+ USE module_wrf_error
+#endif
+
+!------------------------------------------------------------------
+ IMPLICIT NONE
+!------------------------------------------------------------------
+
+ INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
+ ims,ime, jms,jme, kms,kme, &
+ its,ite, jts,jte, kts,kte
+ LOGICAL, INTENT(IN ) :: F_QV,F_QC,F_QR,F_QI,F_QS,F_QG
+ LOGICAL, INTENT(INout) :: doabsems
+ LOGICAL, INTENT(IN ) :: dolw,dosw
+
+ INTEGER, INTENT(IN ) :: n_cldadv
+ INTEGER, INTENT(IN ) :: JULDAY
+ REAL, INTENT(IN ) :: JULIAN
+ INTEGER, INTENT(IN ) :: YR
+ REAL, INTENT(IN ) :: DT
+ INTEGER, INTENT(IN ) :: levsiz, num_months
+ INTEGER, INTENT(IN ) :: paerlev, naer_c
+ INTEGER, INTENT(IN ) :: cam_abs_dim1, cam_abs_dim2
+
+
+ REAL, INTENT(IN ) :: RADT,DEGRAD, &
+ XTIME,DECLIN,SOLCON,GMT
+!
+!
+ REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
+ INTENT(IN ) :: P_PHY, &
+ P8W, &
+ Z, &
+ pi_PHY, &
+ rho_PHY, &
+ dz8w, &
+ T_PHY, &
+ QV3D, &
+ QC3D, &
+ QR3D, &
+ QI3D, &
+ QS3D, &
+ QG3D, &
+ CLDFRA
+
+ REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
+ INTENT(INOUT) :: RTHRATENLW, &
+ RTHRATENSW
+!
+ REAL, DIMENSION( ims:ime, jms:jme ), &
+ INTENT(IN ) :: XLAT, &
+ XLONG, &
+ XLAND, &
+ XICE, &
+ SNOW, &
+ EMISS, &
+ TSK, &
+ ALBEDO
+
+ REAL, DIMENSION( ims:ime, levsiz, jms:jme, num_months ), &
+ INTENT(IN ) :: OZMIXM
+
+ REAL, DIMENSION(levsiz), INTENT(IN ) :: PIN0
+
+ REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN ) :: m_psp,m_psn
+ REAL, DIMENSION(paerlev), intent(in) :: m_hybi0
+ REAL, DIMENSION( ims:ime, paerlev, jms:jme, naer_c ), &
+ INTENT(IN ) :: aerosolcp, aerosolcn
+
+!
+ REAL, DIMENSION( ims:ime, jms:jme ), &
+ INTENT(INOUT) :: GSW, GLW
+
+! saving arrays for doabsems reduction of radiation calcs
+
+ REAL, DIMENSION( ims:ime, kms:kme, cam_abs_dim2 , jms:jme ), &
+ INTENT(INOUT) :: abstot_3d
+ REAL, DIMENSION( ims:ime, kms:kme, cam_abs_dim1 , jms:jme ), &
+ INTENT(INOUT) :: absnxt_3d
+ REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
+ INTENT(INOUT) :: emstot_3d
+
+
+! Added outputs of total and clearsky fluxes etc
+! Note that k=1 refers to the half level below the model lowest level (Sfc)
+! k=kme refers to the half level above the model highest level (TOA)
+!
+! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
+! INTENT(INOUT) :: swup, &
+! swupclear, &
+! swdn, &
+! swdnclear, &
+! lwup, &
+! lwupclear, &
+! lwdn, &
+! lwdnclear
+
+ REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT) ::&
+ SWUPT,SWUPTC,SWDNT,SWDNTC, &
+ LWUPT,LWUPTC,LWDNT,LWDNTC, &
+ SWUPB,SWUPBC,SWDNB,SWDNBC, &
+ LWUPB,LWUPBC,LWDNB,LWDNBC
+
+ REAL, DIMENSION( ims:ime, jms:jme ), &
+ INTENT(INOUT) :: swcf, &
+ lwcf, &
+ olr, &
+ coszr
+ REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
+ INTENT(OUT ) :: cemiss, & ! cloud emissivity for isccp
+ taucldc, & ! cloud water optical depth for isccp
+ taucldi ! cloud ice optical depth for isccp
+!
+!
+ REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
+ INTENT(IN ) :: &
+ F_ICE_PHY, &
+ F_RAIN_PHY
+
+
+! LOCAL VARIABLES
+
+ INTEGER :: lchnk, ncol, pcols, pver, pverp, pverr, pverrp
+ INTEGER :: pcnst, pnats, ppcnst, i, j, k, ii, kk, kk1, m, n
+ integer :: begchunk, endchunk
+ integer :: nyrm, nyrp
+ real(r8) doymodel, doydatam, doydatap, deltat, fact1, fact2
+
+ REAL :: XT24, TLOCTM, HRANG, XXLAT, oldXT24
+
+ real(r8), DIMENSION( 1:ite-its+1 ) :: coszrs, landfrac, landm, snowh, icefrac, lwups
+ real(r8), DIMENSION( 1:ite-its+1 ) :: asdir, asdif, aldir, aldif, ps
+ real(r8), DIMENSION( 1:ite-its+1, 1:kte-kts+1 ) :: cld, pmid, lnpmid, pdel, zm, t
+ real(r8), DIMENSION( 1:ite-its+1, 1:kte-kts+2 ) :: pint, lnpint
+ real(r8), DIMENSION( 1:ite-its+1, 1:kte-kts+1, n_cldadv) :: q
+! real(r8), DIMENSION( 1:kte-kts+1 ) :: hypm ! reference pressures at midpoints
+! real(r8), DIMENSION( 1:kte-kts+2 ) :: hypi ! reference pressures at interfaces
+ real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: cicewp ! in-cloud cloud ice water path
+ real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: cliqwp ! in-cloud cloud liquid water path
+ real(r8), dimension( 1:ite-its+1, 0:kte-kts+1 ) :: tauxcl ! cloud water optical depth
+ real(r8), dimension( 1:ite-its+1, 0:kte-kts+1 ) :: tauxci ! cloud ice optical depth
+ real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: emis ! cloud emissivity
+ real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: rel ! effective drop radius (microns)
+ real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: rei ! ice effective drop size (microns)
+ real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: pmxrgn ! Maximum values of pressure for each
+ integer , dimension( 1:ite-its+1 ) :: nmxrgn ! Number of maximally overlapped regions
+
+ real(r8), dimension( 1:ite-its+1 ) :: fsns ! Surface absorbed solar flux
+ real(r8), dimension( 1:ite-its+1 ) :: fsnt ! Net column abs solar flux at model top
+ real(r8), dimension( 1:ite-its+1 ) :: flns ! Srf longwave cooling (up-down) flux
+ real(r8), dimension( 1:ite-its+1 ) :: flnt ! Net outgoing lw flux at model top
+! Added outputs of total and clearsky fluxes etc
+ real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsup ! Upward total sky solar
+ real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsupc ! Upward clear sky solar
+ real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsdn ! Downward total sky solar
+ real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsdnc ! Downward clear sky solar
+ real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: flup ! Upward total sky longwave
+ real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: flupc ! Upward clear sky longwave
+ real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fldn ! Downward total sky longwave
+ real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fldnc ! Downward clear sky longwave
+ real(r8), dimension( 1:ite-its+1 ) :: swcftoa ! Top of the atmosphere solar cloud forcing
+ real(r8), dimension( 1:ite-its+1 ) :: lwcftoa ! Top of the atmosphere longwave cloud forcing
+ real(r8), dimension( 1:ite-its+1 ) :: olrtoa ! Top of the atmosphere outgoing longwave
+!
+ real(r8), dimension( 1:ite-its+1 ) :: sols ! Downward solar rad onto surface (sw direct)
+ real(r8), dimension( 1:ite-its+1 ) :: soll ! Downward solar rad onto surface (lw direct)
+ real(r8), dimension( 1:ite-its+1 ) :: solsd ! Downward solar rad onto surface (sw diffuse)
+ real(r8), dimension( 1:ite-its+1 ) :: solld ! Downward solar rad onto surface (lw diffuse)
+ real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: qrs ! Solar heating rate
+ real(r8), dimension( 1:ite-its+1 ) :: fsds ! Flux Shortwave Downwelling Surface
+ real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: qrl ! Longwave cooling rate
+ real(r8), dimension( 1:ite-its+1 ) :: flwds ! Surface down longwave flux
+ real(r8), dimension( 1:ite-its+1, levsiz, num_months ) :: ozmixmj ! monthly ozone mixing ratio
+ real(r8), dimension( 1:ite-its+1, levsiz ) :: ozmix ! ozone mixing ratio (time interpolated)
+ real(r8), dimension(levsiz) :: pin ! ozone pressure level
+ real(r8), dimension(1:ite-its+1) :: m_psjp,m_psjn ! MATCH surface pressure
+ real(r8), dimension( 1:ite-its+1, paerlev, naer_c ) :: aerosoljp ! monthly aerosol concentrations
+ real(r8), dimension( 1:ite-its+1, paerlev, naer_c ) :: aerosoljn ! monthly aerosol concentrations
+ real(r8), dimension(paerlev) :: m_hybi
+ real(r8), dimension(1:ite-its+1 ) :: clat ! latitude in radians for columns
+ real(r8), dimension(its:ite,kts:kte+1,kts:kte+1) :: abstot ! Total absorptivity
+ real(r8), dimension(its:ite,kts:kte,4) :: absnxt ! Total nearest layer absorptivity
+ real(r8), dimension(its:ite,kts:kte+1) :: emstot ! Total emissivity
+ CHARACTER(LEN=256) :: msgstr
+
+#if !defined(MAC_KLUDGE)
+ lchnk = 1
+ begchunk = ims
+ endchunk = ime
+ ncol = ite - its + 1
+ pcols= ite - its + 1
+ pver = kte - kts + 1
+ pverp= pver + 1
+ pverr = kte - kts + 1
+ pverrp= pverr + 1
+! number of advected constituents and non-advected constituents (including water vapor)
+ ppcnst = n_cldadv
+! number of non-advected constituents
+ pnats = 0
+ pcnst = ppcnst-pnats
+
+! check the # species defined for the input climatology and naer
+
+! if(naer_c.ne.naer) then
+! WRITE( wrf_err_message , * ) 'naer_c ne naer ', naer_c, naer
+#if (defined(non_hydrostatic_core) || defined(hydrostatic_core))
+ if(naer_c.ne.naer_all) then
+ write(mpas_err_message,*) 'naer_c-1 ne naer_all ', naer_c, naer_all
+ call physics_error_fatal(mpas_err_message)
+ endif
+#else
+ if(naer_c.ne.naer_all) then
+ WRITE( wrf_err_message , * ) 'naer_c-1 ne naer_all ', naer_c, naer_all
+ CALL wrf_error_fatal ( wrf_err_message )
+ endif
+#endif
+
+! update CO2 volume mixing ratio (co2vmr)
+
+! determine time interpolation factors, check sanity
+! of interpolation factors to within 32-bit roundoff
+! assume that day of year is 1 for all input data
+!
+ nyrm = yr - yrdata(1) + 1
+ nyrp = nyrm + 1
+ doymodel = yr*365. + julian
+ doydatam = yrdata(nyrm)*365. + 1.
+ doydatap = yrdata(nyrp)*365. + 1.
+ deltat = doydatap - doydatam
+ fact1 = (doydatap - doymodel)/deltat
+ fact2 = (doymodel - doydatam)/deltat
+ co2vmr = (co2(nyrm)*fact1 + co2(nyrp)*fact2)*1.e-06
+
+ co2mmr=co2vmr*mwco2/mwdry
+!
+!===================================================
+! Radiation computations
+!===================================================
+
+ do k=1,levsiz
+ pin(k)=pin0(k)
+ enddo
+
+ do k=1,paerlev
+ m_hybi(k)=m_hybi0(k)
+ enddo
+
+! check for uninitialized arrays
+#if (defined(non_hydrostatic_core) || defined(hydrostatic_core))
+ if(abstot_3d(its,kts,kts,jts) .eq. 0.0 .and. .not.doabsems .and. dolw) then
+ write(mpas_err_message,*) ' camrad lw: CAUTION: re-calculating abstot,absnxt, on restart'
+ call physics_message(mpas_err_message)
+ doabsems = .true.
+ endif
+#else
+ if(abstot_3d(its,kts,kts,jts) .eq. 0.0 .and. .not.doabsems .and. dolw)then
+ CALL wrf_debug(0, 'camrad lw: CAUTION: re-calculating abstot, absnxt, emstot on restart')
+ doabsems = .true.
+ endif
+#endif
+
+ do j =jts,jte
+
+!
+! Cosine solar zenith angle for current time step
+!
+
+! call zenith (calday, clat, clon, coszrs, ncol)
+
+ do i = its,ite
+ ii = i - its + 1
+ ! XT24 is the fractional part of simulation days plus half of RADT expressed in
+ ! units of minutes
+ ! JULIAN is in days
+ ! RADT is in minutes
+ XT24=MOD(XTIME+RADT*0.5,1440.)
+ TLOCTM=GMT+XT24/60.+XLONG(I,J)/15.
+ HRANG=15.*(TLOCTM-12.)*DEGRAD
+ XXLAT=XLAT(I,J)*DEGRAD
+ clat(ii)=xxlat
+ coszrs(II)=SIN(XXLAT)*SIN(DECLIN)+COS(XXLAT)*COS(DECLIN)*COS(HRANG)
+ enddo
+
+! moist variables
+
+ do k = kts,kte
+ kk = kte - k + kts
+ do i = its,ite
+ ii = i - its + 1
+! convert to specific humidity
+ q(ii,kk,1) = max(1.e-10,qv3d(i,k,j)/(1.+qv3d(i,k,j)))
+ IF ( F_QI .and. F_QC .and. F_QS ) THEN
+ q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j)/(1.+qv3d(i,k,j)))
+ q(ii,kk,ixcldice) = max(0.,(qi3d(i,k,j)+qs3d(i,k,j))/(1.+qv3d(i,k,j)))
+ ELSE IF ( F_QC .and. F_QR ) THEN
+! Warm rain or simple ice
+ q(ii,kk,ixcldliq) = 0.
+ q(ii,kk,ixcldice) = 0.
+ if(t_phy(i,k,j).gt.273.15)q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j)/(1.+qv3d(i,k,j)))
+ if(t_phy(i,k,j).le.273.15)q(ii,kk,ixcldice) = max(0.,qc3d(i,k,j)/(1.+qv3d(i,k,j)))
+ ELSE IF ( F_QC .and. F_QS ) THEN
+! For Ferrier (note that currently Ferrier has QI, so this section will not be used)
+ q(ii,kk,ixcldice) = max(0.,qc3d(i,k,j)/(1.+qv3d(i,k,j))*f_ice_phy(i,k,j))
+ q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j)/(1.+qv3d(i,k,j))*(1.-f_ice_phy(i,k,j))*(1.-f_rain_phy(i,k,j)))
+ ELSE
+ q(ii,kk,ixcldliq) = 0.
+ q(ii,kk,ixcldice) = 0.
+ ENDIF
+ cld(ii,kk) = CLDFRA(I,K,J)
+ enddo
+ enddo
+
+ do i = its,ite
+ ii = i - its + 1
+ landfrac(ii) = 2.-XLAND(I,J)
+ landm(ii) = landfrac(ii)
+ snowh(ii) = 0.001*SNOW(I,J)
+ icefrac(ii) = XICE(I,J)
+ enddo
+
+!ldf (05-15-2011): In MPAS num_months ranges from 1 to 12 (instead of 2 to 13 in WRF):
+#if (defined(non_hydrostatic_core) || defined(hydrostatic_core))
+ do m=1,num_months
+ do k=1,levsiz
+ do i = its,ite
+ ii = i - its + 1
+ ozmixmj(ii,k,m) = ozmixm(i,k,j,m)
+ enddo
+ enddo
+ enddo
+#else
+ do m=1,num_months-1
+ do k=1,levsiz
+ do i = its,ite
+ ii = i - its + 1
+ ozmixmj(ii,k,m) = ozmixm(i,k,j,m+1)
+ enddo
+ enddo
+ enddo
+#endif
+
+ do i = its,ite
+ ii = i - its + 1
+ m_psjp(ii) = m_psp(i,j)
+ m_psjn(ii) = m_psn(i,j)
+ enddo
+
+ do n=1,naer_c
+ do k=1,paerlev
+ do i = its,ite
+ ii = i - its + 1
+ aerosoljp(ii,k,n) = aerosolcp(i,k,j,n)
+ aerosoljn(ii,k,n) = aerosolcn(i,k,j,n)
+ enddo
+ enddo
+ enddo
+
+!
+! Complete radiation calculations
+!
+ do i = its,ite
+ ii = i - its + 1
+ lwups(ii) = stebol*EMISS(I,J)*TSK(I,J)**4
+ enddo
+
+ do k = kts,kte+1
+ kk = kte - k + kts + 1
+ do i = its,ite
+ ii = i - its + 1
+ pint(ii,kk) = p8w(i,k,j)
+ if(k.eq.kts)ps(ii)=pint(ii,kk)
+ lnpint(ii,kk) = log(pint(ii,kk))
+ enddo
+ enddo
+
+ if(.not.doabsems .and. dolw)then
+! do kk = kts,kte+1
+ do kk = 1,cam_abs_dim2
+ do kk1 = kts,kte+1
+ do i = its,ite
+ abstot(i,kk1,kk) = abstot_3d(i,kk1,kk,j)
+ enddo
+ enddo
+ enddo
+! do kk = 1,4
+ do kk = 1,cam_abs_dim1
+ do kk1 = kts,kte
+ do i = its,ite
+ absnxt(i,kk1,kk) = absnxt_3d(i,kk1,kk,j)
+ enddo
+ enddo
+ enddo
+ do kk = kts,kte+1
+ do i = its,ite
+ emstot(i,kk) = emstot_3d(i,kk,j)
+ enddo
+ enddo
+ endif
+
+ do k = kts,kte
+ kk = kte - k + kts
+ do i = its,ite
+ ii = i - its + 1
+ pmid(ii,kk) = p_phy(i,k,j)
+ lnpmid(ii,kk) = log(pmid(ii,kk))
+ lnpint(ii,kk) = log(pint(ii,kk))
+ pdel(ii,kk) = pint(ii,kk+1) - pint(ii,kk)
+ t(ii,kk) = t_phy(i,k,j)
+ zm(ii,kk) = z(i,k,j)
+ enddo
+ enddo
+
+
+! Compute cloud water/ice paths and optical properties for input to radiation
+
+ call param_cldoptics_calc(ncol, pcols, pver, pverp, pverr, pverrp, ppcnst, q, cld, landfrac, landm,icefrac, &
+ pdel, t, ps, pmid, pint, cicewp, cliqwp, emis, rel, rei, pmxrgn, nmxrgn, snowh)
+
+ do i = its,ite
+ ii = i - its + 1
+! use same albedo for direct and diffuse
+! change this when separate values are provided
+ asdir(ii) = albedo(i,j)
+ asdif(ii) = albedo(i,j)
+ aldir(ii) = albedo(i,j)
+ aldif(ii) = albedo(i,j)
+ enddo
+
+! WRF allocate space here (not needed if oznini is called)
+! allocate (ozmix(pcols,levsiz,begchunk:endchunk)) ! This line from oznini.F90
+
+ call radctl (j,lchnk, ncol, pcols, pver, pverp, pverr, pverrp, ppcnst, pcnst, lwups, emis, pmid, &
+ pint, lnpmid, lnpint, pdel, t, q, &
+ cld, cicewp, cliqwp, tauxcl, tauxci, coszrs, clat, asdir, asdif, &
+ aldir, aldif, solcon, GMT,JULDAY,JULIAN,DT,XTIME, &
+ pin, ozmixmj, ozmix, levsiz, num_months, &
+ m_psjp,m_psjn, aerosoljp, aerosoljn, m_hybi, paerlev, naer_c, pmxrgn, nmxrgn, &
+ dolw, dosw, doabsems, abstot, absnxt, emstot, &
+ fsup, fsupc, fsdn, fsdnc, flup, flupc, fldn, fldnc, swcftoa, lwcftoa, olrtoa, &
+ fsns, fsnt ,flns ,flnt , &
+ qrs, qrl, flwds, rel, rei, &
+ sols, soll, solsd, solld, &
+ landfrac, zm, fsds)
+
+ do k = kts,kte
+ kk = kte - k + kts
+ do i = its,ite
+ ii = i - its + 1
+ if(dolw)RTHRATENLW(I,K,J) = 1.e4*qrl(ii,kk)/(cpair*pi_phy(i,k,j))
+ if(dosw)RTHRATENSW(I,K,J) = 1.e4*qrs(ii,kk)/(cpair*pi_phy(i,k,j))
+ cemiss(i,k,j) = emis(ii,kk)
+ taucldc(i,k,j) = tauxcl(ii,kk)
+ taucldi(i,k,j) = tauxci(ii,kk)
+ enddo
+ enddo
+
+ if(doabsems .and. dolw)then
+! do kk = kts,kte+1
+ do kk = 1,cam_abs_dim2
+ do kk1 = kts,kte+1
+ do i = its,ite
+ abstot_3d(i,kk1,kk,j) = abstot(i,kk1,kk)
+ enddo
+ enddo
+ enddo
+! do kk = 1,4
+ do kk = 1,cam_abs_dim1
+ do kk1 = kts,kte
+ do i = its,ite
+ absnxt_3d(i,kk1,kk,j) = absnxt(i,kk1,kk)
+ enddo
+ enddo
+ enddo
+ do kk = kts,kte+1
+ do i = its,ite
+ emstot_3d(i,kk,j) = emstot(i,kk)
+ enddo
+ enddo
+ endif
+
+ IF(PRESENT(SWUPT))THEN
+ if(dosw)then
+! Added shortwave and longwave upward/downward total and clear sky fluxes
+ do k = kts,kte+1
+ kk = kte +1 - k + kts
+ do i = its,ite
+ ii = i - its + 1
+! swup(i,k,j) = fsup(ii,kk)
+! swupclear(i,k,j) = fsupc(ii,kk)
+! swdn(i,k,j) = fsdn(ii,kk)
+! swdnclear(i,k,j) = fsdnc(ii,kk)
+ if(k.eq.kte+1)then
+ swupt(i,j) = fsup(ii,kk)
+ swuptc(i,j) = fsupc(ii,kk)
+ swdnt(i,j) = fsdn(ii,kk)
+ swdntc(i,j) = fsdnc(ii,kk)
+ endif
+ if(k.eq.kts)then
+ swupb(i,j) = fsup(ii,kk)
+ swupbc(i,j) = fsupc(ii,kk)
+ swdnb(i,j) = fsdn(ii,kk)
+ swdnbc(i,j) = fsdnc(ii,kk)
+ endif
+! if(i.eq.30.and.j.eq.30) then
+! print 1234, 'short ', i,ii,k,kk,fsup(ii,kk),fsupc(ii,kk),fsdn(ii,kk),fsdnc(ii,kk)
+! 1234 format (a6,4i4,4f10.3)
+! endif
+ enddo
+ enddo
+ endif
+ if(dolw)then
+! Added shortwave and longwave upward/downward total and clear sky fluxes
+ do k = kts,kte+1
+ kk = kte +1 - k + kts
+ do i = its,ite
+ ii = i - its + 1
+! lwup(i,k,j) = flup(ii,kk)
+! lwupclear(i,k,j) = flupc(ii,kk)
+! lwdn(i,k,j) = fldn(ii,kk)
+! lwdnclear(i,k,j) = fldnc(ii,kk)
+ if(k.eq.kte+1)then
+ lwupt(i,j) = flup(ii,kk)
+ lwuptc(i,j) = flupc(ii,kk)
+ lwdnt(i,j) = fldn(ii,kk)
+ lwdntc(i,j) = fldnc(ii,kk)
+ endif
+ if(k.eq.kts)then
+ lwupb(i,j) = flup(ii,kk)
+ lwupbc(i,j) = flupc(ii,kk)
+ lwdnb(i,j) = fldn(ii,kk)
+ lwdnbc(i,j) = fldnc(ii,kk)
+ endif
+! if(i.eq.30.and.j.eq.30) then
+! print 1234, 'long ', i,ii,k,kk,flup(ii,kk),flupc(ii,kk),fldn(ii,kk),fldnc(ii,kk)
+! 1234 format (a6,4i4,4f10.3)
+! endif
+ enddo
+ enddo
+ endif
+ ENDIF
+
+ do i = its,ite
+ ii = i - its + 1
+! Added shortwave and longwave cloud forcing at TOA and surface
+ if(dolw)then
+ GLW(I,J) = flwds(ii)
+ lwcf(i,j) = lwcftoa(ii)
+ olr(i,j) = olrtoa(ii)
+ endif
+ if(dosw)then
+ GSW(I,J) = fsns(ii)
+ swcf(i,j) = swcftoa(ii)
+ coszr(i,j) = coszrs(ii)
+ endif
+ enddo
+
+ enddo ! j-loop
+
+#endif
+
+end subroutine camrad
+
+!LDF (05-01-2011): This section of the module is moved to module_physics_ra_cam_init.F in
+!./../core_physics to accomodate differences in the mpi calls between WRF and MPAS.I thought
+!that it would be cleaner to do this instead of adding a lot of #ifdef statements throughout
+!the initialization of the longwave radiation code. Initialization is handled the same way
+!for the shortwave radiation code.
+
+#if !(defined(non_hydrostatic_core) || defined(hydrostatic_core))
+
+!====================================================================
+ SUBROUTINE camradinit( &
+ R_D,R_V,CP,G,STBOLT,EP_2,shalf,pptop, &
+ ozmixm,pin,levsiz,XLAT,num_months, &
+ m_psp,m_psn,m_hybi,aerosolcp,aerosolcn, &
+ paerlev,naer_c, &
+ ids, ide, jds, jde, kds, kde, &
+ ims, ime, jms, jme, kms, kme, &
+ its, ite, jts, jte, kts, kte )
+
+ USE module_wrf_error
+ USE module_state_description
+ !USE module_configure
+
+!--------------------------------------------------------------------
+ IMPLICIT NONE
+!--------------------------------------------------------------------
+ INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, &
+ ims, ime, jms, jme, kms, kme, &
+ its, ite, jts, jte, kts, kte
+ REAL, intent(in) :: pptop
+ REAL, INTENT(IN) :: R_D,R_V,CP,G,STBOLT,EP_2
+
+ REAL, DIMENSION( kms:kme ) :: shalf
+
+ INTEGER, INTENT(IN ) :: levsiz, num_months
+ INTEGER, INTENT(IN ) :: paerlev, naer_c
+
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: XLAT
+
+ REAL, DIMENSION( ims:ime, levsiz, jms:jme, num_months ), &
+ INTENT(INOUT ) :: OZMIXM
+
+ REAL, DIMENSION(levsiz), INTENT(INOUT ) :: PIN
+ REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT ) :: m_psp,m_psn
+ REAL, DIMENSION(paerlev), INTENT(INOUT ) :: m_hybi
+ REAL, DIMENSION( ims:ime, paerlev, jms:jme, naer_c ), &
+ INTENT(INOUT) :: aerosolcp,aerosolcn
+
+ REAL(r8) :: pstd
+ REAL(r8) :: rh2o, cpair
+
+! These were made allocatable 20090612 to save static memory allocation. JM
+ IF ( .NOT. ALLOCATED( ksul ) ) ALLOCATE( ksul( nrh, nspint ) )
+ IF ( .NOT. ALLOCATED( wsul ) ) ALLOCATE( wsul( nrh, nspint ) )
+ IF ( .NOT. ALLOCATED( gsul ) ) ALLOCATE( gsul( nrh, nspint ) )
+ IF ( .NOT. ALLOCATED( ksslt ) ) ALLOCATE( ksslt( nrh, nspint ) )
+ IF ( .NOT. ALLOCATED( wsslt ) ) ALLOCATE( wsslt( nrh, nspint ) )
+ IF ( .NOT. ALLOCATED( gsslt ) ) ALLOCATE( gsslt( nrh, nspint ) )
+ IF ( .NOT. ALLOCATED( kcphil ) ) ALLOCATE( kcphil( nrh, nspint ) )
+ IF ( .NOT. ALLOCATED( wcphil ) ) ALLOCATE( wcphil( nrh, nspint ) )
+ IF ( .NOT. ALLOCATED( gcphil ) ) ALLOCATE( gcphil( nrh, nspint ) )
+
+ IF ( .NOT. ALLOCATED(ah2onw ) ) ALLOCATE( ah2onw(n_p, n_tp, n_u, n_te, n_rh) )
+ IF ( .NOT. ALLOCATED(eh2onw ) ) ALLOCATE( eh2onw(n_p, n_tp, n_u, n_te, n_rh) )
+ IF ( .NOT. ALLOCATED(ah2ow ) ) ALLOCATE( ah2ow(n_p, n_tp, n_u, n_te, n_rh) )
+ IF ( .NOT. ALLOCATED(cn_ah2ow) ) ALLOCATE( cn_ah2ow(n_p, n_tp, n_u, n_te, n_rh) )
+ IF ( .NOT. ALLOCATED(cn_eh2ow) ) ALLOCATE( cn_eh2ow(n_p, n_tp, n_u, n_te, n_rh) )
+ IF ( .NOT. ALLOCATED(ln_ah2ow) ) ALLOCATE( ln_ah2ow(n_p, n_tp, n_u, n_te, n_rh) )
+ IF ( .NOT. ALLOCATED(ln_eh2ow) ) ALLOCATE( ln_eh2ow(n_p, n_tp, n_u, n_te, n_rh) )
+
+#if !defined(MAC_KLUDGE)
+ ozncyc = .true.
+ indirect = .true.
+ ixcldliq = 2
+ ixcldice = 3
+#if (NMM_CORE != 1)
+! aerosol array is not in the NMM Registry
+! since CAM radiation not available to NMM (yet)
+! so this is blocked out to enable CAM compilation with NMM
+ idxSUL = P_SUL
+ idxSSLT = P_SSLT
+ idxDUSTfirst = P_DUST1
+ idxOCPHO = P_OCPHO
+ idxCARBONfirst = P_OCPHO
+ idxBCPHO = P_BCPHO
+ idxOCPHI = P_OCPHI
+ idxBCPHI = P_BCPHI
+ idxBG = P_BG
+ idxVOLC = P_VOLC
+#endif
+
+ pstd = 101325.0
+! from physconst module
+ mwdry = 28.966 ! molecular weight dry air ~ kg/kmole (shr_const_mwdair)
+ mwco2 = 44. ! molecular weight co2
+ mwh2o = 18.016 ! molecular weight water vapor (shr_const_mwwv)
+ mwch4 = 16. ! molecular weight ch4
+ mwn2o = 44. ! molecular weight n2o
+ mwf11 = 136. ! molecular weight cfc11
+ mwf12 = 120. ! molecular weight cfc12
+ cappa = R_D/CP
+ rair = R_D
+ tmelt = 273.16 ! freezing T of fresh water ~ K
+ r_universal = 6.02214e26 * STBOLT ! Universal gas constant ~ J/K/kmole
+ latvap = 2.501e6 ! latent heat of evaporation ~ J/kg
+ latice = 3.336e5 ! latent heat of fusion ~ J/kg
+ zvir = R_V/R_D - 1.
+ rh2o = R_V
+ cpair = CP
+!
+ epsqs = EP_2
+
+ CALL radini(G, CP, EP_2, STBOLT, pstd*10.0 )
+ CALL esinti(epsqs ,latvap ,latice ,rh2o ,cpair ,tmelt )
+ CALL oznini(ozmixm,pin,levsiz,num_months,XLAT, &
+ ids, ide, jds, jde, kds, kde, &
+ ims, ime, jms, jme, kms, kme, &
+ its, ite, jts, jte, kts, kte)
+ CALL aerosol_init(m_psp,m_psn,m_hybi,aerosolcp,aerosolcn,paerlev,naer_c,shalf,pptop, &
+ ids, ide, jds, jde, kds, kde, &
+ ims, ime, jms, jme, kms, kme, &
+ its, ite, jts, jte, kts, kte)
+
+#endif
+
+ END SUBROUTINE camradinit
+#endif !ldf (05-01-2011)
+#if !defined(MAC_KLUDGE)
+
+
+subroutine oznint(julday,julian,dt,gmt,xtime,ozmixmj,ozmix,levsiz,num_months,pcols)
+
+ IMPLICIT NONE
+
+ INTEGER, INTENT(IN ) :: levsiz, num_months,pcols
+
+ REAL(r8), DIMENSION( pcols, levsiz, num_months ), &
+ INTENT(IN ) :: ozmixmj
+
+ REAL, INTENT(IN ) :: XTIME,GMT
+ INTEGER, INTENT(IN ) :: JULDAY
+ REAL, INTENT(IN ) :: JULIAN
+ REAL, INTENT(IN ) :: DT
+
+ REAL(r8), DIMENSION( pcols, levsiz ), &
+ INTENT(OUT ) :: ozmix
+ !Local
+ REAL(r8) :: intJULIAN
+ integer :: np1,np,nm,m,k,i
+ integer :: IJUL
+ integer, dimension(12) :: date_oz
+ data date_oz/16, 45, 75, 105, 136, 166, 197, 228, 258, 289, 319, 350/
+ real(r8) :: cdayozp, cdayozm
+ real(r8) :: fact1, fact2
+ logical :: finddate
+ CHARACTER(LEN=256) :: msgstr
+
+ ! JULIAN starts from 0.0 at 0Z on 1 Jan.
+ intJULIAN = JULIAN + 1.0_r8 ! offset by one day
+! jan 1st 00z is julian=1.0 here
+ IJUL=INT(intJULIAN)
+! Note that following will drift.
+! Need to use actual month/day info to compute julian.
+ intJULIAN=intJULIAN-FLOAT(IJUL)
+ IJUL=MOD(IJUL,365)
+ IF(IJUL.EQ.0)IJUL=365
+ intJULIAN=intJULIAN+IJUL
+ np1=1
+ finddate=.false.
+! do m=1,num_months
+ do m=1,12
+ if(date_oz(m).gt.intjulian.and..not.finddate) then
+ np1=m
+ finddate=.true.
+ endif
+ enddo
+ cdayozp=date_oz(np1)
+ if(np1.gt.1) then
+ cdayozm=date_oz(np1-1)
+ np=np1
+ nm=np-1
+ else
+ cdayozm=date_oz(12)
+ np=np1
+ nm=12
+ endif
+ call getfactors(ozncyc,np1, cdayozm, cdayozp,intjulian, &
+ fact1, fact2)
+
+!
+! Time interpolation.
+!
+ do k=1,levsiz
+ do i=1,pcols
+ ozmix(i,k) = ozmixmj(i,k,nm)*fact1 + ozmixmj(i,k,np)*fact2
+ end do
+ end do
+
+END subroutine oznint
+
+
+subroutine get_aerosol(c, julday, julian, dt, gmt, xtime, m_psp, m_psn, aerosoljp, &
+ aerosoljn, m_hybi, paerlev, naer_c, pint, pcols, pver, pverp, pverr, pverrp, AEROSOLt, scale)
+!------------------------------------------------------------------
+!
+! Input:
+! time at which aerosol mmrs are needed (get_curr_calday())
+! chunk index
+! CAM's vertical grid (pint)
+!
+! Output:
+! values for Aerosol Mass Mixing Ratios at specified time
+! on vertical grid specified by CAM (AEROSOLt)
+!
+! Method:
+! first determine which indexs of aerosols are the bounding data sets
+! interpolate both onto vertical grid aerm(),aerp().
+! from those two, interpolate in time.
+!
+!------------------------------------------------------------------
+
+! use volcanicmass, only: get_volcanic_mass
+! use timeinterp, only: getfactors
+!
+! aerosol fields interpolated to current time step
+! on pressure levels of this time step.
+! these should be made read-only for other modules
+! Is allocation done correctly here?
+!
+ integer, intent(in) :: c ! Chunk Id.
+ integer, intent(in) :: paerlev, naer_c, pcols, pver, pverp, pverr, pverrp
+ real(r8), intent(in) :: pint(pcols,pverp) ! midpoint pres.
+ real(r8), intent(in) :: scale(naer_all) ! scale each aerosol by this amount
+ REAL, INTENT(IN ) :: XTIME,GMT
+ INTEGER, INTENT(IN ) :: JULDAY
+ REAL, INTENT(IN ) :: JULIAN
+ REAL, INTENT(IN ) :: DT
+ real(r8), intent(in ) :: m_psp(pcols),m_psn(pcols) ! Match surface pressure
+ real(r8), intent(in ) :: aerosoljp(pcols,paerlev,naer_c)
+ real(r8), intent(in ) :: aerosoljn(pcols,paerlev,naer_c)
+ real(r8), intent(in ) :: m_hybi(paerlev)
+
+ real(r8), intent(out) :: AEROSOLt(pcols, pver, naer_all) ! aerosols
+!
+! Local workspace
+!
+ real(r8) caldayloc ! calendar day of current timestep
+ real(r8) fact1, fact2 ! time interpolation factors
+
+ integer :: nm = 1 ! index to prv month in array. init to 1 and toggle between 1 and 2
+ integer :: np = 2 ! index to nxt month in array. init to 2 and toggle between 1 and 2
+ integer :: mo_nxt = bigint ! index to nxt month in file
+ integer :: mo_prv ! index to previous month
+
+ real(r8) :: cdaym = inf ! calendar day of prv month
+ real(r8) :: cdayp = inf ! calendar day of next month
+ real(r8) :: Mid(12) ! Days into year for mid month date
+ data Mid/16.5, 46.0, 75.5, 106.0, 136.5, 167.0, 197.5, 228.5, 259.0, 289.5, 320.0, 350.5 /
+
+ integer i, k, j ! spatial indices
+ integer m ! constituent index
+ integer lats(pcols),lons(pcols) ! latitude and longitudes of column
+ integer ncol ! number of columns
+ INTEGER IJUL
+ REAL(r8) intJULIAN
+
+ real(r8) speciesmin(naer) ! minimal value for each species
+!
+! values before current time step "the minus month"
+! aerosolm(pcols,pver) is value of preceeding month's aerosol mmr
+! aerosolp(pcols,pver) is value of next month's aerosol mmr
+! (think minus and plus or values to left and right of point to be interpolated)
+!
+ real(r8) AEROSOLm(pcols,pver,naer) ! aerosol mmr from MATCH in column at previous (minus) month
+!
+! values beyond (or at) current time step "the plus month"
+!
+ real(r8) AEROSOLp(pcols,pver,naer) ! aerosol mmr from MATCH in column at next (plus) month
+ CHARACTER(LEN=256) :: msgstr
+
+ ! JULIAN starts from 0.0 at 0Z on 1 Jan.
+ intJULIAN = JULIAN + 1.0_r8 ! offset by one day
+! jan 1st 00z is julian=1.0 here
+ IJUL=INT(intJULIAN)
+! Note that following will drift.
+! Need to use actual month/day info to compute julian.
+ intJULIAN=intJULIAN-FLOAT(IJUL)
+ IJUL=MOD(IJUL,365)
+ IF(IJUL.EQ.0)IJUL=365
+ caldayloc=intJULIAN+IJUL
+
+ if (caldayloc < Mid(1)) then
+ mo_prv = 12
+ mo_nxt = 1
+ else if (caldayloc >= Mid(12)) then
+ mo_prv = 12
+ mo_nxt = 1
+ else
+ do i = 2 , 12
+ if (caldayloc < Mid(i)) then
+ mo_prv = i-1
+ mo_nxt = i
+ exit
+ end if
+ end do
+ end if
+!
+! Set initial calendar day values
+!
+ cdaym = Mid(mo_prv)
+ cdayp = Mid(mo_nxt)
+
+!
+! Determine time interpolation factors. 1st arg says we are cycling 1 year of data
+!
+ call getfactors (.true., mo_nxt, cdaym, cdayp, caldayloc, &
+ fact1, fact2)
+!
+! interpolate (prv and nxt month) bounding datasets onto cam vertical grid.
+! compute mass mixing ratios on CAMS's pressure coordinate
+! for both the "minus" and "plus" months
+!
+! ncol = get_ncols_p(c)
+ ncol = pcols
+
+! call vert_interpolate (M_ps_cam_col(1,c,nm), pint, nm, AEROSOLm, ncol, c)
+! call vert_interpolate (M_ps_cam_col(1,c,np), pint, np, AEROSOLp, ncol, c)
+
+ call vert_interpolate (m_psp, aerosoljp, m_hybi, paerlev, naer_c, pint, nm, AEROSOLm, pcols, pver, pverp, ncol, c)
+ call vert_interpolate (m_psn, aerosoljn, m_hybi, paerlev, naer_c, pint, np, AEROSOLp, pcols, pver, pverp, ncol, c)
+
+!
+! Time interpolate.
+!
+ do m=1,naer
+ do k=1,pver
+ do i=1,ncol
+ AEROSOLt(i,k,m) = AEROSOLm(i,k,m)*fact1 + AEROSOLp(i,k,m)*fact2
+ end do
+ end do
+ end do
+
+! do i=1,ncol
+! Match_ps_chunk(i,c) = m_ps(i,nm)*fact1 + m_ps(i,np)*fact2
+! end do
+!
+! get background aerosol (tuning) field
+!
+ call background (c, ncol, pint, pcols, pverr, pverrp, AEROSOLt(:, :, idxBG))
+
+!
+! find volcanic aerosol masses
+!
+! if (strat_volcanic) then
+! call get_volcanic_mass(c, AEROSOLt(:,:,idxVOLC))
+! else
+ AEROSOLt(:,:,idxVOLC) = 0._r8
+! endif
+
+!
+! exit if mmr is negative (we have previously set
+! cumulative mass to be a decreasing function.)
+!
+ speciesmin(:) = 0. ! speciesmin(m) = 0 is minimum mmr for each species
+
+ do m=1,naer
+ do k=1,pver
+ do i=1,ncol
+ if (AEROSOLt(i, k, m) < speciesmin(m)) then
+ write(6,*) 'AEROSOL_INTERPOLATE: negative mass mixing ratio, exiting'
+ write(6,*) 'm, column, pver',m, i, k ,AEROSOLt(i, k, m)
+ call endrun ()
+ end if
+ end do
+ end do
+ end do
+!
+! scale any AEROSOLS as required
+!
+ call scale_aerosols (AEROSOLt, pcols, pver, ncol, c, scale)
+
+ return
+end subroutine get_aerosol
+
+
+subroutine aerosol_indirect(ncol,lchnk,pcols,pver,ppcnst,landfrac,pmid,t,qm1,cld,zm,rel)
+!--------------------------------------------------------------
+! Compute effect of sulfate on effective liquid water radius
+! Method of Martin et. al.
+!--------------------------------------------------------------
+
+! use constituents, only: ppcnst, cnst_get_ind
+! use history, only: outfld
+
+!#include <comctl.h>
+
+ integer, intent(in) :: ncol ! number of atmospheric columns
+ integer, intent(in) :: lchnk ! chunk identifier
+ integer, intent(in) :: pcols,pver,ppcnst
+
+ real(r8), intent(in) :: landfrac(pcols) ! land fraction
+ real(r8), intent(in) :: pmid(pcols,pver) ! Model level pressures
+ real(r8), intent(in) :: t(pcols,pver) ! Model level temperatures
+ real(r8), intent(in) :: qm1(pcols,pver,ppcnst) ! Specific humidity and tracers
+ real(r8), intent(in) :: cld(pcols,pver) ! Fractional cloud cover
+ real(r8), intent(in) :: zm(pcols,pver) ! Height of midpoints (above surface)
+ real(r8), intent(in) :: rel(pcols,pver) ! liquid effective drop size (microns)
+!
+! local variables
+!
+ real(r8) locrhoair(pcols,pver) ! dry air density [kg/m^3 ]
+ real(r8) lwcwat(pcols,pver) ! in-cloud liquid water path [kg/m^3 ]
+ real(r8) sulfmix(pcols,pver) ! sulfate mass mixing ratio [kg/kg ]
+ real(r8) so4mass(pcols,pver) ! sulfate mass concentration [g/cm^3 ]
+ real(r8) Aso4(pcols,pver) ! sulfate # concentration [#/cm^3 ]
+ real(r8) Ntot(pcols,pver) ! ccn # concentration [#/cm^3 ]
+ real(r8) relmod(pcols,pver) ! effective radius [microns]
+
+ real(r8) wrel(pcols,pver) ! weighted effective radius [microns]
+ real(r8) wlwc(pcols,pver) ! weighted liq. water content [kg/m^3 ]
+ real(r8) cldfrq(pcols,pver) ! frequency of occurance of...
+! ! clouds (cld => 0.01) [fraction]
+ real(r8) locPi ! my piece of the pi
+ real(r8) Rdryair ! gas constant of dry air [J/deg/kg]
+ real(r8) rhowat ! density of water [kg/m^3 ]
+ real(r8) Acoef ! m->A conversion factor; assumes
+! ! Dbar=0.10, sigma=2.0 [g^-1 ]
+ real(r8) rekappa ! kappa in evaluation of re(lmod)
+ real(r8) recoef ! temp. coeficient for calc of re(lmod)
+ real(r8) reexp ! 1.0/3.0
+ real(r8) Ntotb ! temp var to hold below cloud ccn
+! -- Parameters for background CDNC (from `ambient' non-sulfate aerosols)...
+ real(r8) Cmarn ! Coef for CDNC_marine [cm^-3]
+ real(r8) Cland ! Coef for CDNC_land [cm^-3]
+ real(r8) Hmarn ! Scale height for CDNC_marine [m]
+ real(r8) Hland ! Scale height for CDNC_land [m]
+ parameter ( Cmarn = 50.0, Cland = 100.0 )
+ parameter ( Hmarn = 1000.0, Hland = 2000.0 )
+ real(r8) bgaer ! temp var to hold background CDNC
+
+ integer i,k ! loop indices
+!
+! Statement functions
+!
+ logical land ! is this a column over land?
+ land(i) = nint(landfrac(i)).gt.0.5_r8
+
+ if (indirect) then
+
+! call endrun ('AEROSOL_INDIRECT: indirect effect is obsolete')
+
+! ramping is not yet resolved so sulfmix is 0.
+ sulfmix(1:ncol,1:pver) = 0._r8
+
+ locPi = 3.141592654
+ Rdryair = 287.04
+ rhowat = 1000.0
+ Acoef = 1.2930E14
+ recoef = 3.0/(4.0*locPi*rhowat)
+ reexp = 1.0/3.0
+
+! call cnst_get_ind('CLDLIQ', ixcldliq)
+ do k=pver,1,-1
+ do i = 1,ncol
+ locrhoair(i,k) = pmid(i,k)/( Rdryair*t(i,k) )
+ lwcwat(i,k) = ( qm1(i,k,ixcldliq)/max(0.01_r8,cld(i,k)) )* &
+ locrhoair(i,k)
+! NOTE: 0.001 converts kg/m3 -> g/cm3
+ so4mass(i,k) = sulfmix(i,k)*locrhoair(i,k)*0.001
+ Aso4(i,k) = so4mass(i,k)*Acoef
+
+ if (Aso4(i,k) <= 280.0) then
+ Aso4(i,k) = max(36.0_r8,Aso4(i,k))
+ Ntot(i,k) = -1.15E-3*Aso4(i,k)**2 + 0.963*Aso4(i,k)+5.30
+ rekappa = 0.80
+ else
+ Aso4(i,k) = min(1500.0_r8,Aso4(i,k))
+ Ntot(i,k) = -2.10E-4*Aso4(i,k)**2 + 0.568*Aso4(i,k)-27.9
+ rekappa = 0.67
+ end if
+ if (land(i)) then ! Account for local background aerosol;
+ bgaer = Cland*exp(-(zm(i,k)/Hland))
+ Ntot(i,k) = max(bgaer,Ntot(i,k))
+ else
+ bgaer = Cmarn*exp(-(zm(i,k)/Hmarn))
+ Ntot(i,k) = max(bgaer,Ntot(i,k))
+ end if
+
+ if (k == pver) then
+ Ntotb = Ntot(i,k)
+ else
+ Ntotb = Ntot(i,k+1)
+ end if
+
+ relmod(i,k) = (( (recoef*lwcwat(i,k))/(rekappa*Ntotb))**reexp)*10000.0
+ relmod(i,k) = max(4.0_r8,relmod(i,k))
+ relmod(i,k) = min(20.0_r8,relmod(i,k))
+ if (cld(i,k) >= 0.01) then
+ cldfrq(i,k) = 1.0
+ else
+ cldfrq(i,k) = 0.0
+ end if
+ wrel(i,k) = relmod(i,k)*cldfrq(i,k)
+ wlwc(i,k) = lwcwat(i,k)*cldfrq(i,k)
+ end do
+ end do
+! call outfld('MSO4 ',so4mass,pcols,lchnk)
+! call outfld('LWC ',lwcwat ,pcols,lchnk)
+! call outfld('CLDFRQ ',cldfrq ,pcols,lchnk)
+! call outfld('WREL ',wrel ,pcols,lchnk)
+! call outfld('WLWC ',wlwc ,pcols,lchnk)
+! write(6,*)'WARNING: indirect calculation has no effects'
+ else
+ do k = 1, pver
+ do i = 1, ncol
+ relmod(i,k) = rel(i,k)
+ end do
+ end do
+ endif
+
+! call outfld('REL ',relmod ,pcols,lchnk)
+
+ return
+end subroutine aerosol_indirect
+
+
+ subroutine aer_trn(aer_mpp, aer_trn_ttl, pcols, plev, plevp )
+!
+! Purpose: Compute strat. aerosol transmissions needed in absorptivity/
+! emissivity calculations
+! aer_trn() is called by radclw() when doabsems is .true.
+!
+! use shr_kind_mod, only: r8 => shr_kind_r8
+! use pmgrid
+! use ppgrid
+! use prescribed_aerosols, only: strat_volcanic
+ implicit none
+
+! Input arguments
+!
+! [kg m-2] Volcanics path above kth interface level
+!
+ integer, intent(in) :: pcols, plev, plevp
+ real(r8), intent(in) :: aer_mpp(pcols,plevp)
+
+! Output arguments
+!
+! [fraction] Total volcanic transmission between interfaces k1 and k2
+!
+ real(r8), intent(out) :: aer_trn_ttl(pcols,plevp,plevp,bnd_nbr_LW)
+
+!-------------------------------------------------------------------------
+! Local variables
+
+ integer bnd_idx ! LW band index
+ integer i ! lon index
+ integer k1 ! lev index
+ integer k2 ! lev index
+ real(r8) aer_pth_dlt ! [kg m-2] Volcanics path between interface
+ ! levels k1 and k2
+ real(r8) odap_aer_ttl ! [fraction] Total path absorption optical
+ ! depth
+
+!-------------------------------------------------------------------------
+
+ if (strat_volcanic) then
+ do bnd_idx=1,bnd_nbr_LW
+ do i=1,pcols
+ aer_trn_ttl(i,1,1,bnd_idx)=1.0
+ end do
+ do k1=2,plevp
+ do i=1,pcols
+ aer_trn_ttl(i,k1,k1,bnd_idx)=1.0
+
+ aer_pth_dlt = abs(aer_mpp(i,k1) - aer_mpp(i,1))
+ odap_aer_ttl = abs_cff_mss_aer(bnd_idx) * aer_pth_dlt
+
+ aer_trn_ttl(i,1,k1,bnd_idx) = exp(-1.66 * odap_aer_ttl)
+ end do
+ end do
+
+ do k1=2,plev
+ do k2=k1+1,plevp
+ do i=1,pcols
+ aer_trn_ttl(i,k1,k2,bnd_idx) = &
+ aer_trn_ttl(i,1,k2,bnd_idx) / &
+ aer_trn_ttl(i,1,k1,bnd_idx)
+ end do
+ end do
+ end do
+
+ do k1=2,plevp
+ do k2=1,k1-1
+ do i=1,pcols
+ aer_trn_ttl(i,k1,k2,bnd_idx)=aer_trn_ttl(i,k2,k1,bnd_idx)
+ end do
+ end do
+ end do
+ end do
+ else
+ aer_trn_ttl = 1.0
+ endif
+
+ return
+ end subroutine aer_trn
+
+ subroutine aer_pth(aer_mass, aer_mpp, ncol, pcols, plev, plevp)
+!------------------------------------------------------
+! Purpose: convert mass per layer to cumulative mass from Top
+!------------------------------------------------------
+! use shr_kind_mod, only: r8 => shr_kind_r8
+! use ppgrid
+! use pmgrid
+ implicit none
+!#include <crdcon.h>
+
+! Parameters
+! Input
+ integer, intent(in) :: pcols, plev, plevp
+ real(r8), intent(in):: aer_mass(pcols,plev) ! Rad level aerosol mass mixing ratio
+ integer, intent(in):: ncol
+!
+! Output
+ real(r8), intent(out):: aer_mpp(pcols,plevp) ! [kg m-2] Volcanics path above kth interface
+!
+! Local
+ integer i ! Column index
+ integer k ! Level index
+!------------------------------------------------------
+!------------------------------------------------------
+
+ aer_mpp(1:ncol,1) = 0._r8
+ do k=2,plevp
+ aer_mpp(1:ncol,k) = aer_mpp(1:ncol,k-1) + aer_mass(1:ncol,k-1)
+ enddo
+!
+ return
+ end subroutine aer_pth
+
+subroutine radctl(j, lchnk ,ncol , pcols, pver, pverp, pverr, pverrp, ppcnst, pcnst, &
+ lwups ,emis , &
+ pmid ,pint ,pmln ,piln ,pdel ,t , &
+! qm1 ,cld ,cicewp ,cliqwp ,coszrs, clat, &
+ qm1 ,cld ,cicewp ,cliqwp ,tauxcl, tauxci, coszrs, clat, &
+ asdir ,asdif ,aldir ,aldif ,solcon, GMT,JULDAY,JULIAN,DT,XTIME, &
+ pin, ozmixmj, ozmix, levsiz, num_months, &
+ m_psp, m_psn, aerosoljp, aerosoljn, m_hybi, paerlev, naer_c, pmxrgn , &
+ nmxrgn , &
+ dolw, dosw, doabsems, abstot, absnxt, emstot, &
+ fsup ,fsupc ,fsdn ,fsdnc , &
+ flup ,flupc ,fldn ,fldnc , &
+ swcf ,lwcf ,flut , &
+ fsns ,fsnt ,flns ,flnt , &
+ qrs ,qrl ,flwds ,rel ,rei , &
+ sols ,soll ,solsd ,solld , &
+ landfrac,zm ,fsds )
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Driver for radiation computation.
+!
+! Method:
+! Radiation uses cgs units, so conversions must be done from
+! model fields to radiation fields.
+!
+! Author: CCM1, CMS Contact: J. Truesdale
+!
+!-----------------------------------------------------------------------
+! use shr_kind_mod, only: r8 => shr_kind_r8
+! use ppgrid
+! use pspect
+! use commap
+! use history, only: outfld
+! use constituents, only: ppcnst, cnst_get_ind
+! use prescribed_aerosols, only: get_aerosol, naer_all, aerosol_diagnostics, &
+! aerosol_indirect, get_rf_scales, get_int_scales, radforce, idxVOLC
+! use physics_types, only: physics_state
+! use wv_saturation, only: aqsat
+! use chemistry, only: trace_gas
+! use physconst, only: cpair, epsilo
+! use aer_optics, only: idxVIS
+! use aerosol_intr, only: set_aerosol_from_prognostics
+
+
+ implicit none
+
+!
+! Input arguments
+!
+ integer, intent(in) :: lchnk,j ! chunk identifier
+ integer, intent(in) :: ncol ! number of atmospheric columns
+ integer, intent(in) :: levsiz ! number of ozone data levels
+ integer, intent(in) :: num_months ! 12 months
+ integer, intent(in) :: paerlev,naer_c ! aerosol vertical level and # species
+ integer, intent(in) :: pcols, pver, pverp, pverr, pverrp, ppcnst, pcnst
+ logical, intent(in) :: dolw,dosw,doabsems
+
+
+ integer nspint ! Num of spctrl intervals across solar spectrum
+ integer naer_groups ! Num of aerosol groups for optical diagnostics
+ parameter ( nspint = 19 )
+ parameter ( naer_groups = 7 ) ! current groupings are sul, sslt, all carbons, all dust, background, and all aerosols
+
+
+ real(r8), intent(in) :: lwups(pcols) ! Longwave up flux at surface
+ real(r8), intent(in) :: emis(pcols,pver) ! Cloud emissivity
+ real(r8), intent(in) :: pmid(pcols,pver) ! Model level pressures
+ real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressures
+ real(r8), intent(in) :: pmln(pcols,pver) ! Natural log of pmid
+ real(r8), intent(in) :: rel(pcols,pver) ! liquid effective drop size (microns)
+ real(r8), intent(in) :: rei(pcols,pver) ! ice effective drop size (microns)
+ real(r8), intent(in) :: piln(pcols,pverp) ! Natural log of pint
+ real(r8), intent(in) :: pdel(pcols,pverp) ! Pressure difference across layer
+ real(r8), intent(in) :: t(pcols,pver) ! Model level temperatures
+ real(r8), intent(in) :: qm1(pcols,pver,ppcnst) ! Specific humidity and tracers
+ real(r8), intent(in) :: cld(pcols,pver) ! Fractional cloud cover
+ real(r8), intent(in) :: cicewp(pcols,pver) ! in-cloud cloud ice water path
+ real(r8), intent(in) :: cliqwp(pcols,pver) ! in-cloud cloud liquid water path
+ real(r8), intent(inout) :: tauxcl(pcols,0:pver) ! cloud water optical depth
+ real(r8), intent(inout) :: tauxci(pcols,0:pver) ! cloud ice optical depth
+ real(r8), intent(in) :: coszrs(pcols) ! Cosine solar zenith angle
+ real(r8), intent(in) :: clat(pcols) ! latitude in radians for columns
+ real(r8), intent(in) :: asdir(pcols) ! albedo shortwave direct
+ real(r8), intent(in) :: asdif(pcols) ! albedo shortwave diffuse
+ real(r8), intent(in) :: aldir(pcols) ! albedo longwave direct
+ real(r8), intent(in) :: aldif(pcols) ! albedo longwave diffuse
+ real(r8), intent(in) :: landfrac(pcols) ! land fraction
+ real(r8), intent(in) :: zm(pcols,pver) ! Height of midpoints (above surface)
+ real(r8), intent(in) :: pin(levsiz) ! Pressure levels of ozone data
+ real(r8), intent(in) :: ozmixmj(pcols,levsiz,num_months) ! monthly ozone mixing ratio
+ real(r8), intent(inout) :: ozmix(pcols,levsiz) ! Ozone data
+ real, intent(in) :: solcon ! solar constant with eccentricity factor
+ REAL, INTENT(IN ) :: XTIME,GMT
+ INTEGER, INTENT(IN ) :: JULDAY
+ REAL, INTENT(IN ) :: JULIAN
+ REAL, INTENT(IN ) :: DT
+ real(r8), intent(in) :: m_psp(pcols),m_psn(pcols) ! MATCH surface pressure
+ real(r8), intent(in) :: aerosoljp(pcols,paerlev,naer_c) ! aerosol concentrations
+ real(r8), intent(in) :: aerosoljn(pcols,paerlev,naer_c) ! aerosol concentrations
+ real(r8), intent(in) :: m_hybi(paerlev)
+! type(physics_state), intent(in) :: state
+ real(r8), intent(inout) :: pmxrgn(pcols,pverp) ! Maximum values of pmid for each
+! maximally overlapped region.
+! 0->pmxrgn(i,1) is range of pmid for
+! 1st region, pmxrgn(i,1)->pmxrgn(i,2) for
+! 2nd region, etc
+ integer, intent(inout) :: nmxrgn(pcols) ! Number of maximally overlapped regions
+
+ real(r8) :: pmxrgnrf(pcols,pverp) ! temporary copy of pmxrgn
+ integer :: nmxrgnrf(pcols) ! temporary copy of nmxrgn
+
+!
+! Output solar arguments
+!
+ real(r8), intent(out) :: fsns(pcols) ! Surface absorbed solar flux
+ real(r8), intent(out) :: fsnt(pcols) ! Net column abs solar flux at model top
+ real(r8), intent(out) :: flns(pcols) ! Srf longwave cooling (up-down) flux
+ real(r8), intent(out) :: flnt(pcols) ! Net outgoing lw flux at model top
+ real(r8), intent(out) :: sols(pcols) ! Downward solar rad onto surface (sw direct)
+ real(r8), intent(out) :: soll(pcols) ! Downward solar rad onto surface (lw direct)
+ real(r8), intent(out) :: solsd(pcols) ! Downward solar rad onto surface (sw diffuse)
+ real(r8), intent(out) :: solld(pcols) ! Downward solar rad onto surface (lw diffuse)
+ real(r8), intent(out) :: qrs(pcols,pver) ! Solar heating rate
+ real(r8), intent(out) :: fsds(pcols) ! Flux Shortwave Downwelling Surface
+! Added outputs of total and clearsky fluxes etc
+ real(r8), intent(out) :: fsup(pcols,pverp) ! Upward total sky solar
+ real(r8), intent(out) :: fsupc(pcols,pverp) ! Upward clear sky solar
+ real(r8), intent(out) :: fsdn(pcols,pverp) ! Downward total sky solar
+ real(r8), intent(out) :: fsdnc(pcols,pverp) ! Downward clear sky solar
+ real(r8), intent(out) :: flup(pcols,pverp) ! Upward total sky longwave
+ real(r8), intent(out) :: flupc(pcols,pverp) ! Upward clear sky longwave
+ real(r8), intent(out) :: fldn(pcols,pverp) ! Downward total sky longwave
+ real(r8), intent(out) :: fldnc(pcols,pverp) ! Downward clear sky longwave
+ real(r8), intent(out) :: swcf(pcols) ! Top of the atmosphere solar cloud forcing
+ real(r8), intent(out) :: lwcf(pcols) ! Top of the atmosphere longwave cloud forcing
+ real(r8), intent(out) :: flut(pcols) ! Top of the atmosphere outgoing longwave
+!
+! Output longwave arguments
+!
+ real(r8), intent(out) :: qrl(pcols,pver) ! Longwave cooling rate
+ real(r8), intent(out) :: flwds(pcols) ! Surface down longwave flux
+
+ real(r8), intent(inout) :: abstot(pcols,pverp,pverp) ! Total absorptivity
+ real(r8), intent(inout) :: absnxt(pcols,pver,4) ! Total nearest layer absorptivity
+ real(r8), intent(inout) :: emstot(pcols,pverp) ! Total emissivity
+
+
+!
+!---------------------------Local variables-----------------------------
+!
+ integer i, k ! index
+
+ integer :: in2o, ich4, if11, if12 ! indexes of gases in constituent array
+
+ real(r8) solin(pcols) ! Solar incident flux
+! real(r8) fsds(pcols) ! Flux Shortwave Downwelling Surface
+ real(r8) fsntoa(pcols) ! Net solar flux at TOA
+ real(r8) fsntoac(pcols) ! Clear sky net solar flux at TOA
+ real(r8) fsnirt(pcols) ! Near-IR flux absorbed at toa
+ real(r8) fsnrtc(pcols) ! Clear sky near-IR flux absorbed at toa
+ real(r8) fsnirtsq(pcols) ! Near-IR flux absorbed at toa >= 0.7 microns
+ real(r8) fsntc(pcols) ! Clear sky total column abs solar flux
+ real(r8) fsnsc(pcols) ! Clear sky surface abs solar flux
+ real(r8) fsdsc(pcols) ! Clear sky surface downwelling solar flux
+! real(r8) flut(pcols) ! Upward flux at top of model
+! real(r8) lwcf(pcols) ! longwave cloud forcing
+! real(r8) swcf(pcols) ! shortwave cloud forcing
+ real(r8) flutc(pcols) ! Upward Clear Sky flux at top of model
+ real(r8) flntc(pcols) ! Clear sky lw flux at model top
+ real(r8) flnsc(pcols) ! Clear sky lw flux at srf (up-down)
+ real(r8) ftem(pcols,pver) ! temporary array for outfld
+
+ real(r8) pbr(pcols,pverr) ! Model mid-level pressures (dynes/cm2)
+ real(r8) pnm(pcols,pverrp) ! Model interface pressures (dynes/cm2)
+ real(r8) o3vmr(pcols,pverr) ! Ozone volume mixing ratio
+ real(r8) o3mmr(pcols,pverr) ! Ozone mass mixing ratio
+ real(r8) eccf ! Earth/sun distance factor
+ real(r8) n2o(pcols,pver) ! nitrous oxide mass mixing ratio
+ real(r8) ch4(pcols,pver) ! methane mass mixing ratio
+ real(r8) cfc11(pcols,pver) ! cfc11 mass mixing ratio
+ real(r8) cfc12(pcols,pver) ! cfc12 mass mixing ratio
+ real(r8) rh(pcols,pverr) ! level relative humidity (fraction)
+ real(r8) lwupcgs(pcols) ! Upward longwave flux in cgs units
+
+ real(r8) esat(pcols,pverr) ! saturation vapor pressure
+ real(r8) qsat(pcols,pverr) ! saturation specific humidity
+
+ real(r8) :: frc_day(pcols) ! = 1 for daylight, =0 for night colums
+ real(r8) :: aertau(pcols,nspint,naer_groups) ! Aerosol column optical depth
+ real(r8) :: aerssa(pcols,nspint,naer_groups) ! Aerosol column averaged single scattering albedo
+ real(r8) :: aerasm(pcols,nspint,naer_groups) ! Aerosol column averaged asymmetry parameter
+ real(r8) :: aerfwd(pcols,nspint,naer_groups) ! Aerosol column averaged forward scattering
+
+ real(r8) aerosol(pcols, pver, naer_all) ! aerosol mass mixing ratios
+ real(r8) scales(naer_all) ! scaling factors for aerosols
+
+
+!
+! Interpolate ozone volume mixing ratio to model levels
+!
+! WRF: added pin, levsiz, ozmix here
+ call oznint(julday,julian,dt,gmt,xtime,ozmixmj,ozmix,levsiz,num_months,pcols)
+
+ call radozn(lchnk ,ncol &
+ ,pcols, pver &
+ ,pmid ,pin, levsiz, ozmix, o3vmr )
+
+! call outfld('O3VMR ',o3vmr ,pcols, lchnk)
+
+!
+! Set chunk dependent radiation input
+!
+ call radinp(lchnk ,ncol ,pcols, pver, pverp, &
+ pmid ,pint ,o3vmr , pbr ,&
+ pnm ,eccf ,o3mmr )
+
+!
+! Solar radiation computation
+!
+ if (dosw) then
+
+!
+! calculate heating with aerosols
+!
+ call aqsat(t, pmid, esat, qsat, pcols, &
+ ncol, pver, 1, pver)
+
+ ! calculate relative humidity
+! rh(1:ncol,1:pver) = q(1:ncol,1:pver,1) / qsat(1:ncol,1:pver) * &
+! ((1.0 - epsilo) * qsat(1:ncol,1:pver) + epsilo) / &
+! ((1.0 - epsilo) * q(1:ncol,1:pver,1) + epsilo)
+ rh(1:ncol,1:pver) = qm1(1:ncol,1:pver,1) / qsat(1:ncol,1:pver) * &
+ ((1.0 - epsilo) * qsat(1:ncol,1:pver) + epsilo) / &
+ ((1.0 - epsilo) * qm1(1:ncol,1:pver,1) + epsilo)
+
+ if (radforce) then
+
+ pmxrgnrf = pmxrgn
+ nmxrgnrf = nmxrgn
+
+ call get_rf_scales(scales)
+
+ call get_aerosol(lchnk, julday, julian, dt, gmt, xtime, m_psp, m_psn, aerosoljp, &
+ aerosoljn, m_hybi, paerlev, naer, pint, pcols, pver, pverp, pverr, pverrp, aerosol, scales)
+
+ ! overwrite with prognostics aerosols
+
+! no feedback from prognostic aerosols
+! call set_aerosol_from_prognostics (ncol, q, aerosol)
+
+ call aerosol_indirect(ncol,lchnk,pcols,pver,ppcnst,landfrac,pmid,t,qm1,cld,zm,rel)
+
+! call t_startf('radcswmx_rf')
+ call radcswmx(j, lchnk ,ncol ,pcols, pver, pverp, &
+ pnm ,pbr ,qm1 ,rh ,o3mmr , &
+ aerosol ,cld ,cicewp ,cliqwp ,rel , &
+! rei ,eccf ,coszrs ,scon ,solin ,solcon , &
+ rei ,tauxcl ,tauxci ,eccf ,coszrs ,scon ,solin ,solcon , &
+ asdir ,asdif ,aldir ,aldif ,nmxrgnrf, &
+ pmxrgnrf,qrs ,fsnt ,fsntc ,fsntoa , &
+ fsntoac ,fsnirt ,fsnrtc ,fsnirtsq,fsns , &
+ fsnsc ,fsdsc ,fsds ,sols ,soll , &
+ solsd ,solld ,frc_day , &
+ fsup ,fsupc ,fsdn ,fsdnc , &
+ aertau ,aerssa ,aerasm ,aerfwd )
+! call t_stopf('radcswmx_rf')
+
+!
+! Convert units of shortwave fields needed by rest of model from CGS to MKS
+!
+
+ do i = 1, ncol
+ solin(i) = solin(i)*1.e-3
+ fsnt(i) = fsnt(i) *1.e-3
+ fsns(i) = fsns(i) *1.e-3
+ fsntc(i) = fsntc(i)*1.e-3
+ fsnsc(i) = fsnsc(i)*1.e-3
+ end do
+ ftem(:ncol,:pver) = qrs(:ncol,:pver)/cpair
+!
+! Dump shortwave radiation information to history tape buffer (diagnostics)
+!
+! call outfld('QRS_RF ',ftem ,pcols,lchnk)
+! call outfld('FSNT_RF ',fsnt ,pcols,lchnk)
+! call outfld('FSNS_RF ',fsns ,pcols,lchnk)
+! call outfld('FSNTC_RF',fsntc ,pcols,lchnk)
+! call outfld('FSNSC_RF',fsnsc ,pcols,lchnk)
+
+ endif ! if (radforce)
+
+ call get_int_scales(scales)
+
+ call get_aerosol(lchnk, julday, julian, dt, gmt, xtime, m_psp, m_psn, aerosoljp, aerosoljn, &
+ m_hybi, paerlev, naer, pint, pcols, pver, pverp, pverr, pverrp, aerosol, scales)
+
+ ! overwrite with prognostics aerosols
+! call set_aerosol_from_prognostics (ncol, q, aerosol)
+
+ call aerosol_indirect(ncol,lchnk,pcols,pver,ppcnst,landfrac,pmid,t,qm1,cld,zm,rel)
+! call t_startf('radcswmx')
+
+ call radcswmx(j, lchnk ,ncol ,pcols, pver, pverp, &
+ pnm ,pbr ,qm1 ,rh ,o3mmr , &
+ aerosol ,cld ,cicewp ,cliqwp ,rel , &
+! rei ,eccf ,coszrs ,scon ,solin ,solcon , &
+ rei ,tauxcl ,tauxci ,eccf ,coszrs ,scon ,solin ,solcon , &
+ asdir ,asdif ,aldir ,aldif ,nmxrgn , &
+ pmxrgn ,qrs ,fsnt ,fsntc ,fsntoa , &
+ fsntoac ,fsnirt ,fsnrtc ,fsnirtsq,fsns , &
+ fsnsc ,fsdsc ,fsds ,sols ,soll , &
+ solsd ,solld ,frc_day , &
+ fsup ,fsupc ,fsdn ,fsdnc , &
+ aertau ,aerssa ,aerasm ,aerfwd )
+! call t_stopf('radcswmx')
+
+! -- tls ---------------------------------------------------------------2
+!
+! Convert units of shortwave fields needed by rest of model from CGS to MKS
+!
+ do i=1,ncol
+ solin(i) = solin(i)*1.e-3
+ fsds(i) = fsds(i)*1.e-3
+ fsnirt(i)= fsnirt(i)*1.e-3
+ fsnrtc(i)= fsnrtc(i)*1.e-3
+ fsnirtsq(i)= fsnirtsq(i)*1.e-3
+ fsnt(i) = fsnt(i) *1.e-3
+ fsns(i) = fsns(i) *1.e-3
+ fsntc(i) = fsntc(i)*1.e-3
+ fsnsc(i) = fsnsc(i)*1.e-3
+ fsdsc(i) = fsdsc(i)*1.e-3
+ fsntoa(i)=fsntoa(i)*1.e-3
+ fsntoac(i)=fsntoac(i)*1.e-3
+ swcf(i) = fsntoa(i) - fsntoac(i)
+ end do
+ ftem(:ncol,:pver) = qrs(:ncol,:pver)/cpair
+
+! Added upward/downward total and clear sky fluxes
+ do k = 1, pverp
+ do i = 1, ncol
+ fsup(i,k) = fsup(i,k)*1.e-3
+ fsupc(i,k) = fsupc(i,k)*1.e-3
+ fsdn(i,k) = fsdn(i,k)*1.e-3
+ fsdnc(i,k) = fsdnc(i,k)*1.e-3
+ end do
+ end do
+
+!
+! Dump shortwave radiation information to history tape buffer (diagnostics)
+!
+
+! call outfld('frc_day ', frc_day, pcols, lchnk)
+! call outfld('SULOD_v ', aertau(:,idxVIS,1) ,pcols,lchnk)
+! call outfld('SSLTOD_v', aertau(:,idxVIS,2) ,pcols,lchnk)
+! call outfld('CAROD_v ', aertau(:,idxVIS,3) ,pcols,lchnk)
+! call outfld('DUSTOD_v', aertau(:,idxVIS,4) ,pcols,lchnk)
+! call outfld('BGOD_v ', aertau(:,idxVIS,5) ,pcols,lchnk)
+! call outfld('VOLCOD_v', aertau(:,idxVIS,6) ,pcols,lchnk)
+! call outfld('AEROD_v ', aertau(:,idxVIS,7) ,pcols,lchnk)
+! call outfld('AERSSA_v', aerssa(:,idxVIS,7) ,pcols,lchnk)
+! call outfld('AERASM_v', aerasm(:,idxVIS,7) ,pcols,lchnk)
+! call outfld('AERFWD_v', aerfwd(:,idxVIS,7) ,pcols,lchnk)
+! call aerosol_diagnostics (lchnk, ncol, pdel, aerosol)
+
+! call outfld('QRS ',ftem ,pcols,lchnk)
+! call outfld('SOLIN ',solin ,pcols,lchnk)
+! call outfld('FSDS ',fsds ,pcols,lchnk)
+! call outfld('FSNIRTOA',fsnirt,pcols,lchnk)
+! call outfld('FSNRTOAC',fsnrtc,pcols,lchnk)
+! call outfld('FSNRTOAS',fsnirtsq,pcols,lchnk)
+! call outfld('FSNT ',fsnt ,pcols,lchnk)
+! call outfld('FSNS ',fsns ,pcols,lchnk)
+! call outfld('FSNTC ',fsntc ,pcols,lchnk)
+! call outfld('FSNSC ',fsnsc ,pcols,lchnk)
+! call outfld('FSDSC ',fsdsc ,pcols,lchnk)
+! call outfld('FSNTOA ',fsntoa,pcols,lchnk)
+! call outfld('FSNTOAC ',fsntoac,pcols,lchnk)
+! call outfld('SOLS ',sols ,pcols,lchnk)
+! call outfld('SOLL ',soll ,pcols,lchnk)
+! call outfld('SOLSD ',solsd ,pcols,lchnk)
+! call outfld('SOLLD ',solld ,pcols,lchnk)
+
+ end if
+!
+! Longwave radiation computation
+!
+ if (dolw) then
+
+ call get_int_scales(scales)
+
+ call get_aerosol(lchnk, julday, julian, dt, gmt, xtime, m_psp, m_psn, aerosoljp, aerosoljn, &
+ m_hybi, paerlev, naer, pint, pcols, pver, pverp, pverr, pverrp, aerosol, scales)
+
+!
+! Convert upward longwave flux units to CGS
+!
+ do i=1,ncol
+! lwupcgs(i) = lwup(i)*1000.
+ lwupcgs(i) = lwups(i)
+ end do
+!
+! Do longwave computation. If not implementing greenhouse gas code then
+! first specify trace gas mixing ratios. If greenhouse gas code then:
+! o ixtrcg => indx of advected n2o tracer
+! o ixtrcg+1 => indx of advected ch4 tracer
+! o ixtrcg+2 => indx of advected cfc11 tracer
+! o ixtrcg+3 => indx of advected cfc12 tracer
+!
+ if (trace_gas) then
+! call cnst_get_ind('N2O' , in2o)
+! call cnst_get_ind('CH4' , ich4)
+! call cnst_get_ind('CFC11', if11)
+! call cnst_get_ind('CFC12', if12)
+! call t_startf("radclwmx")
+ call radclwmx(lchnk ,ncol ,pcols, pver, pverp , &
+ lwupcgs ,t ,qm1(1,1,1) ,o3vmr , &
+ pbr ,pnm ,pmln ,piln , &
+ qm1(1,1,in2o) ,qm1(1,1,ich4) , &
+ qm1(1,1,if11) ,qm1(1,1,if12) , &
+ cld ,emis ,pmxrgn ,nmxrgn ,qrl , &
+ doabsems, abstot, absnxt, emstot, &
+ flns ,flnt ,flnsc ,flntc ,flwds , &
+ flut ,flutc , &
+ flup ,flupc ,fldn ,fldnc , &
+ aerosol(:,:,idxVOLC))
+! call t_stopf("radclwmx")
+ else
+ call trcmix(lchnk ,ncol ,pcols, pver, &
+ pmid ,clat, n2o ,ch4 , &
+ cfc11 ,cfc12 )
+
+! call t_startf("radclwmx")
+ call radclwmx(lchnk ,ncol ,pcols, pver, pverp , &
+ lwupcgs ,t ,qm1(1,1,1) ,o3vmr , &
+ pbr ,pnm ,pmln ,piln , &
+ n2o ,ch4 ,cfc11 ,cfc12 , &
+ cld ,emis ,pmxrgn ,nmxrgn ,qrl , &
+ doabsems, abstot, absnxt, emstot, &
+ flns ,flnt ,flnsc ,flntc ,flwds , &
+ flut ,flutc , &
+ flup ,flupc ,fldn ,fldnc , &
+ aerosol(:,:,idxVOLC))
+! call t_stopf("radclwmx")
+ endif
+!
+! Convert units of longwave fields needed by rest of model from CGS to MKS
+!
+ do i=1,ncol
+ flnt(i) = flnt(i)*1.e-3
+ flut(i) = flut(i)*1.e-3
+ flutc(i) = flutc(i)*1.e-3
+ flns(i) = flns(i)*1.e-3
+ flntc(i) = flntc(i)*1.e-3
+ flnsc(i) = flnsc(i)*1.e-3
+ flwds(i) = flwds(i)*1.e-3
+ lwcf(i) = flutc(i) - flut(i)
+ end do
+
+! Added upward/downward total and clear sky fluxes
+ do k = 1, pverp
+ do i = 1, ncol
+ flup(i,k) = flup(i,k)*1.e-3
+ flupc(i,k) = flupc(i,k)*1.e-3
+ fldn(i,k) = fldn(i,k)*1.e-3
+ fldnc(i,k) = fldnc(i,k)*1.e-3
+ end do
+ end do
+!
+! Dump longwave radiation information to history tape buffer (diagnostics)
+!
+! call outfld('QRL ',qrl(:ncol,:)/cpair,ncol,lchnk)
+! call outfld('FLNT ',flnt ,pcols,lchnk)
+! call outfld('FLUT ',flut ,pcols,lchnk)
+! call outfld('FLUTC ',flutc ,pcols,lchnk)
+! call outfld('FLNTC ',flntc ,pcols,lchnk)
+! call outfld('FLNS ',flns ,pcols,lchnk)
+! call outfld('FLNSC ',flnsc ,pcols,lchnk)
+! call outfld('LWCF ',lwcf ,pcols,lchnk)
+! call outfld('SWCF ',swcf ,pcols,lchnk)
+!
+ end if
+!
+ return
+end subroutine radctl
+ subroutine param_cldoptics_calc(ncol, pcols, pver, pverp, pverr, pverrp, ppcnst, &
+ q, cldn, landfrac, landm,icefrac, &
+ pdel, t, ps, pmid, pint, cicewp, cliqwp, emis, rel, rei, pmxrgn, nmxrgn, snowh )
+!
+! Compute (liquid+ice) water path and cloud water/ice diagnostics
+! *** soon this code will compute liquid and ice paths from input liquid and ice mixing ratios
+!
+! **** mixes interface and physics code temporarily
+!-----------------------------------------------------------------------
+! use physics_types, only: physics_state
+! use history, only: outfld
+! use pkg_cldoptics, only: cldefr, cldems, cldovrlap, cldclw
+
+ implicit none
+
+! Arguments
+ integer, intent(in) :: ncol, pcols, pver, pverp, pverr, pverrp, ppcnst
+ real(r8), intent(in) :: q(pcols,pver,ppcnst) ! moisture arrays
+ real(r8), intent(in) :: cldn(pcols,pver) ! new cloud fraction
+ real(r8), intent(in) :: pdel(pcols,pver) ! pressure thickness
+ real(r8), intent(in) :: t(pcols,pver) ! temperature
+ real(r8), intent(in) :: pmid(pcols,pver) ! pressure
+ real(r8), intent(in) :: pint(pcols,pverp) ! pressure
+ real(r8), intent(in) :: ps(pcols) ! surface pressure
+ real(r8), intent(in) :: landfrac(pcols) ! Land fraction
+ real(r8), intent(in) :: icefrac(pcols) ! Ice fraction
+ real(r8), intent(in) :: landm(pcols) ! Land fraction ramped
+ real(r8), intent(in) :: snowh(pcols) ! Snow depth over land, water equivalent (m)
+
+!!$ real(r8), intent(out) :: cwp (pcols,pver) ! in-cloud cloud (total) water path
+ real(r8), intent(out) :: cicewp(pcols,pver) ! in-cloud cloud ice water path
+ real(r8), intent(out) :: cliqwp(pcols,pver) ! in-cloud cloud liquid water path
+ real(r8), intent(out) :: emis (pcols,pver) ! cloud emissivity
+ real(r8), intent(out) :: rel (pcols,pver) ! effective drop radius (microns)
+ real(r8), intent(out) :: rei (pcols,pver) ! ice effective drop size (microns)
+ real(r8), intent(out) :: pmxrgn(pcols,pver+1) ! Maximum values of pressure for each
+ integer , intent(out) :: nmxrgn(pcols) ! Number of maximally overlapped regions
+
+! Local variables
+ real(r8) :: cwp (pcols,pver) ! in-cloud cloud (total) water path
+!!$ real(r8) :: cicewp(pcols,pver) ! in-cloud cloud ice water path
+!!$ real(r8) :: cliqwp(pcols,pver) ! in-cloud cloud liquid water path
+ real(r8) :: effcld(pcols,pver) ! effective cloud=cld*emis
+ real(r8) :: gicewp(pcols,pver) ! grid-box cloud ice water path
+ real(r8) :: gliqwp(pcols,pver) ! grid-box cloud liquid water path
+ real(r8) :: gwp (pcols,pver) ! grid-box cloud (total) water path
+ real(r8) :: hl (pcols) ! Liquid water scale height
+ real(r8) :: tgicewp(pcols) ! Vertically integrated ice water path
+ real(r8) :: tgliqwp(pcols) ! Vertically integrated liquid water path
+ real(r8) :: tgwp (pcols) ! Vertically integrated (total) cloud water path
+ real(r8) :: tpw (pcols) ! total precipitable water
+ real(r8) :: clwpold(pcols,pver) ! Presribed cloud liq. h2o path
+ real(r8) :: ficemr (pcols,pver) ! Ice fraction from ice and liquid mixing ratios
+
+ real(r8) :: rgrav ! inverse gravitational acceleration
+
+ integer :: i,k ! loop indexes
+ integer :: lchnk
+
+!-----------------------------------------------------------------------
+
+! Compute liquid and ice water paths
+ tgicewp(:ncol) = 0.
+ tgliqwp(:ncol) = 0.
+ do k=1,pver
+ do i = 1,ncol
+ gicewp(i,k) = q(i,k,ixcldice)*pdel(i,k)/gravmks*1000.0 ! Grid box ice water path.
+ gliqwp(i,k) = q(i,k,ixcldliq)*pdel(i,k)/gravmks*1000.0 ! Grid box liquid water path.
+!!$ gwp (i,k) = gicewp(i,k) + gliqwp(i,k)
+ cicewp(i,k) = gicewp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud ice water path.
+ cliqwp(i,k) = gliqwp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud liquid water path.
+!!$ cwp (i,k) = gwp (i,k) / max(0.01_r8,cldn(i,k))
+ ficemr(i,k) = q(i,k,ixcldice) / &
+ max(1.e-10_r8,(q(i,k,ixcldice)+q(i,k,ixcldliq)))
+
+ tgicewp(i) = tgicewp(i) + gicewp(i,k)
+ tgliqwp(i) = tgliqwp(i) + gliqwp(i,k)
+ end do
+ end do
+ tgwp(:ncol) = tgicewp(:ncol) + tgliqwp(:ncol)
+ gwp(:ncol,:pver) = gicewp(:ncol,:pver) + gliqwp(:ncol,:pver)
+ cwp(:ncol,:pver) = cicewp(:ncol,:pver) + cliqwp(:ncol,:pver)
+
+! Compute total preciptable water in column (in mm)
+ tpw(:ncol) = 0.0
+ rgrav = 1.0/gravmks
+ do k=1,pver
+ do i=1,ncol
+ tpw(i) = tpw(i) + pdel(i,k)*q(i,k,1)*rgrav
+ end do
+ end do
+
+! Diagnostic liquid water path (old specified form)
+! call cldclw(lchnk, ncol, pcols, pver, pverp, state%zi, clwpold, tpw, hl)
+
+! Cloud water and ice particle sizes
+ call cldefr(lchnk, ncol, pcols, pver, pverp, landfrac, t, rel, rei, ps, pmid, landm, icefrac, snowh)
+
+! Cloud emissivity.
+ call cldems(lchnk, ncol, pcols, pver, pverp, cwp, ficemr, rei, emis)
+
+! Effective cloud cover
+ do k=1,pver
+ do i=1,ncol
+ effcld(i,k) = cldn(i,k)*emis(i,k)
+ end do
+ end do
+
+! Determine parameters for maximum/random overlap
+ call cldovrlap(lchnk, ncol, pcols, pver, pverp, pint, cldn, nmxrgn, pmxrgn)
+
+! call outfld('GCLDLWP' ,gwp , pcols,lchnk)
+! call outfld('TGCLDCWP',tgwp , pcols,lchnk)
+! call outfld('TGCLDLWP',tgliqwp, pcols,lchnk)
+! call outfld('TGCLDIWP',tgicewp, pcols,lchnk)
+! call outfld('ICLDLWP' ,cwp , pcols,lchnk)
+! call outfld('SETLWP' ,clwpold, pcols,lchnk)
+! call outfld('EFFCLD' ,effcld , pcols,lchnk)
+! call outfld('LWSH' ,hl , pcols,lchnk)
+
+ end subroutine param_cldoptics_calc
+
+subroutine radabs(lchnk ,ncol ,pcols, pver, pverp, &
+ pbr ,pnm ,co2em ,co2eml ,tplnka , &
+ s2c ,tcg ,w ,h2otr ,plco2 , &
+ plh2o ,co2t ,tint ,tlayr ,plol , &
+ plos ,pmln ,piln ,ucfc11 ,ucfc12 , &
+ un2o0 ,un2o1 ,uch4 ,uco211 ,uco212 , &
+ uco213 ,uco221 ,uco222 ,uco223 ,uptype , &
+ bn2o0 ,bn2o1 ,bch4 ,abplnk1 ,abplnk2 , &
+ abstot ,absnxt ,plh2ob ,wb , &
+ aer_mpp ,aer_trn_ttl)
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Compute absorptivities for h2o, co2, o3, ch4, n2o, cfc11 and cfc12
+!
+! Method:
+! h2o .... Uses nonisothermal emissivity method for water vapor from
+! Ramanathan, V. and P.Downey, 1986: A Nonisothermal
+! Emissivity and Absorptivity Formulation for Water Vapor
+! Journal of Geophysical Research, vol. 91., D8, pp 8649-8666
+!
+! Implementation updated by Collins, Hackney, and Edwards (2001)
+! using line-by-line calculations based upon Hitran 1996 and
+! CKD 2.1 for absorptivity and emissivity
+!
+! Implementation updated by Collins, Lee-Taylor, and Edwards (2003)
+! using line-by-line calculations based upon Hitran 2000 and
+! CKD 2.4 for absorptivity and emissivity
+!
+! co2 .... Uses absorptance parameterization of the 15 micro-meter
+! (500 - 800 cm-1) band system of Carbon Dioxide, from
+! Kiehl, J.T. and B.P.Briegleb, 1991: A New Parameterization
+! of the Absorptance Due to the 15 micro-meter Band System
+! of Carbon Dioxide Jouranl of Geophysical Research,
+! vol. 96., D5, pp 9013-9019.
+! Parameterizations for the 9.4 and 10.4 mircon bands of CO2
+! are also included.
+!
+! o3 .... Uses absorptance parameterization of the 9.6 micro-meter
+! band system of ozone, from Ramanathan, V. and R.Dickinson,
+! 1979: The Role of stratospheric ozone in the zonal and
+! seasonal radiative energy balance of the earth-troposphere
+! system. Journal of the Atmospheric Sciences, Vol. 36,
+! pp 1084-1104
+!
+! ch4 .... Uses a broad band model for the 7.7 micron band of methane.
+!
+! n20 .... Uses a broad band model for the 7.8, 8.6 and 17.0 micron
+! bands of nitrous oxide
+!
+! cfc11 ... Uses a quasi-linear model for the 9.2, 10.7, 11.8 and 12.5
+! micron bands of CFC11
+!
+! cfc12 ... Uses a quasi-linear model for the 8.6, 9.1, 10.8 and 11.2
+! micron bands of CFC12
+!
+!
+! Computes individual absorptivities for non-adjacent layers, accounting
+! for band overlap, and sums to obtain the total; then, computes the
+! nearest layer contribution.
+!
+! Author: W. Collins (H2O absorptivity) and J. Kiehl
+!
+!-----------------------------------------------------------------------
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+ integer, intent(in) :: lchnk ! chunk identifier
+ integer, intent(in) :: ncol ! number of atmospheric columns
+ integer, intent(in) :: pcols, pver, pverp
+
+ real(r8), intent(in) :: pbr(pcols,pver) ! Prssr at mid-levels (dynes/cm2)
+ real(r8), intent(in) :: pnm(pcols,pverp) ! Prssr at interfaces (dynes/cm2)
+ real(r8), intent(in) :: co2em(pcols,pverp) ! Co2 emissivity function
+ real(r8), intent(in) :: co2eml(pcols,pver) ! Co2 emissivity function
+ real(r8), intent(in) :: tplnka(pcols,pverp) ! Planck fnctn level temperature
+ real(r8), intent(in) :: s2c(pcols,pverp) ! H2o continuum path length
+ real(r8), intent(in) :: tcg(pcols,pverp) ! H2o-mass-wgted temp. (Curtis-Godson approx.)
+ real(r8), intent(in) :: w(pcols,pverp) ! H2o prs wghted path
+ real(r8), intent(in) :: h2otr(pcols,pverp) ! H2o trnsmssn fnct for o3 overlap
+ real(r8), intent(in) :: plco2(pcols,pverp) ! Co2 prs wghted path length
+ real(r8), intent(in) :: plh2o(pcols,pverp) ! H2o prs wfhted path length
+ real(r8), intent(in) :: co2t(pcols,pverp) ! Tmp and prs wghted path length
+ real(r8), intent(in) :: tint(pcols,pverp) ! Interface temperatures
+ real(r8), intent(in) :: tlayr(pcols,pverp) ! K-1 level temperatures
+ real(r8), intent(in) :: plol(pcols,pverp) ! Ozone prs wghted path length
+ real(r8), intent(in) :: plos(pcols,pverp) ! Ozone path length
+ real(r8), intent(in) :: pmln(pcols,pver) ! Ln(pmidm1)
+ real(r8), intent(in) :: piln(pcols,pverp) ! Ln(pintm1)
+ real(r8), intent(in) :: plh2ob(nbands,pcols,pverp) ! Pressure weighted h2o path with
+ ! Hulst-Curtis-Godson temp. factor
+ ! for H2O bands
+ real(r8), intent(in) :: wb(nbands,pcols,pverp) ! H2o path length with
+ ! Hulst-Curtis-Godson temp. factor
+ ! for H2O bands
+
+ real(r8), intent(in) :: aer_mpp(pcols,pverp) ! STRAER path above kth interface level
+ real(r8), intent(in) :: aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! aer trn.
+
+
+!
+! Trace gas variables
+!
+ real(r8), intent(in) :: ucfc11(pcols,pverp) ! CFC11 path length
+ real(r8), intent(in) :: ucfc12(pcols,pverp) ! CFC12 path length
+ real(r8), intent(in) :: un2o0(pcols,pverp) ! N2O path length
+ real(r8), intent(in) :: un2o1(pcols,pverp) ! N2O path length (hot band)
+ real(r8), intent(in) :: uch4(pcols,pverp) ! CH4 path length
+ real(r8), intent(in) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length
+ real(r8), intent(in) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length
+ real(r8), intent(in) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length
+ real(r8), intent(in) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length
+ real(r8), intent(in) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length
+ real(r8), intent(in) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length
+ real(r8), intent(in) :: uptype(pcols,pverp) ! continuum path length
+ real(r8), intent(in) :: bn2o0(pcols,pverp) ! pressure factor for n2o
+ real(r8), intent(in) :: bn2o1(pcols,pverp) ! pressure factor for n2o
+ real(r8), intent(in) :: bch4(pcols,pverp) ! pressure factor for ch4
+ real(r8), intent(in) :: abplnk1(14,pcols,pverp) ! non-nearest layer Planck factor
+ real(r8), intent(in) :: abplnk2(14,pcols,pverp) ! nearest layer factor
+!
+! Output arguments
+!
+ real(r8), intent(out) :: abstot(pcols,pverp,pverp) ! Total absorptivity
+ real(r8), intent(out) :: absnxt(pcols,pver,4) ! Total nearest layer absorptivity
+!
+!---------------------------Local variables-----------------------------
+!
+ integer i ! Longitude index
+ integer k ! Level index
+ integer k1 ! Level index
+ integer k2 ! Level index
+ integer kn ! Nearest level index
+ integer wvl ! Wavelength index
+
+ real(r8) abstrc(pcols) ! total trace gas absorptivity
+ real(r8) bplnk(14,pcols,4) ! Planck functions for sub-divided layers
+ real(r8) pnew(pcols) ! Effective pressure for H2O vapor linewidth
+ real(r8) pnewb(nbands) ! Effective pressure for h2o linewidth w/
+ ! Hulst-Curtis-Godson correction for
+ ! each band
+ real(r8) u(pcols) ! Pressure weighted H2O path length
+ real(r8) ub(nbands) ! Pressure weighted H2O path length with
+ ! Hulst-Curtis-Godson correction for
+ ! each band
+ real(r8) tbar(pcols,4) ! Mean layer temperature
+ real(r8) emm(pcols,4) ! Mean co2 emissivity
+ real(r8) o3emm(pcols,4) ! Mean o3 emissivity
+ real(r8) o3bndi ! Ozone band parameter
+ real(r8) temh2o(pcols,4) ! Mean layer temperature equivalent to tbar
+ real(r8) k21 ! Exponential coefficient used to calculate
+! ! rotation band transmissvty in the 650-800
+! ! cm-1 region (tr1)
+ real(r8) k22 ! Exponential coefficient used to calculate
+! ! rotation band transmissvty in the 500-650
+! ! cm-1 region (tr2)
+ real(r8) uc1(pcols) ! H2o continuum pathlength in 500-800 cm-1
+ real(r8) to3h2o(pcols) ! H2o trnsmsn for overlap with o3
+ real(r8) pi ! For co2 absorptivity computation
+ real(r8) sqti(pcols) ! Used to store sqrt of mean temperature
+ real(r8) et ! Co2 hot band factor
+ real(r8) et2 ! Co2 hot band factor squared
+ real(r8) et4 ! Co2 hot band factor to fourth power
+ real(r8) omet ! Co2 stimulated emission term
+ real(r8) f1co2 ! Co2 central band factor
+ real(r8) f2co2(pcols) ! Co2 weak band factor
+ real(r8) f3co2(pcols) ! Co2 weak band factor
+ real(r8) t1co2(pcols) ! Overlap factr weak bands on strong band
+ real(r8) sqwp ! Sqrt of co2 pathlength
+ real(r8) f1sqwp(pcols) ! Main co2 band factor
+ real(r8) oneme ! Co2 stimulated emission term
+ real(r8) alphat ! Part of the co2 stimulated emission term
+ real(r8) wco2 ! Constants used to define co2 pathlength
+ real(r8) posqt ! Effective pressure for co2 line width
+ real(r8) u7(pcols) ! Co2 hot band path length
+ real(r8) u8 ! Co2 hot band path length
+ real(r8) u9 ! Co2 hot band path length
+ real(r8) u13 ! Co2 hot band path length
+ real(r8) rbeta7(pcols) ! Inverse of co2 hot band line width par
+ real(r8) rbeta8 ! Inverse of co2 hot band line width par
+ real(r8) rbeta9 ! Inverse of co2 hot band line width par
+ real(r8) rbeta13 ! Inverse of co2 hot band line width par
+ real(r8) tpatha ! For absorptivity computation
+ real(r8) abso(pcols,4) ! Absorptivity for various gases/bands
+ real(r8) dtx(pcols) ! Planck temperature minus 250 K
+ real(r8) dty(pcols) ! Path temperature minus 250 K
+ real(r8) term7(pcols,2) ! Kl_inf(i) in eq(r8) of table A3a of R&D
+ real(r8) term8(pcols,2) ! Delta kl_inf(i) in eq(r8)
+ real(r8) tr1 ! Eqn(6) in table A2 of R&D for 650-800
+ real(r8) tr10(pcols) ! Eqn (6) times eq(4) in table A2
+! ! of R&D for 500-650 cm-1 region
+ real(r8) tr2 ! Eqn(6) in table A2 of R&D for 500-650
+ real(r8) tr5 ! Eqn(4) in table A2 of R&D for 650-800
+ real(r8) tr6 ! Eqn(4) in table A2 of R&D for 500-650
+ real(r8) tr9(pcols) ! Equation (6) times eq(4) in table A2
+! ! of R&D for 650-800 cm-1 region
+ real(r8) sqrtu(pcols) ! Sqrt of pressure weighted h20 pathlength
+ real(r8) fwk(pcols) ! Equation(33) in R&D far wing correction
+ real(r8) fwku(pcols) ! GU term in eqs(1) and (6) in table A2
+ real(r8) to3co2(pcols) ! P weighted temp in ozone band model
+ real(r8) dpnm(pcols) ! Pressure difference between two levels
+ real(r8) pnmsq(pcols,pverp) ! Pressure squared
+ real(r8) dw(pcols) ! Amount of h2o between two levels
+ real(r8) uinpl(pcols,4) ! Nearest layer subdivision factor
+ real(r8) winpl(pcols,4) ! Nearest layer subdivision factor
+ real(r8) zinpl(pcols,4) ! Nearest layer subdivision factor
+ real(r8) pinpl(pcols,4) ! Nearest layer subdivision factor
+ real(r8) dplh2o(pcols) ! Difference in press weighted h2o amount
+ real(r8) r293 ! 1/293
+ real(r8) r250 ! 1/250
+ real(r8) r3205 ! Line width factor for o3 (see R&Di)
+ real(r8) r300 ! 1/300
+ real(r8) rsslp ! Reciprocal of sea level pressure
+ real(r8) r2sslp ! 1/2 of rsslp
+ real(r8) ds2c ! Y in eq(7) in table A2 of R&D
+ real(r8) dplos ! Ozone pathlength eq(A2) in R&Di
+ real(r8) dplol ! Presure weighted ozone pathlength
+ real(r8) tlocal ! Local interface temperature
+ real(r8) beta ! Ozone mean line parameter eq(A3) in R&Di
+! (includes Voigt line correction factor)
+ real(r8) rphat ! Effective pressure for ozone beta
+ real(r8) tcrfac ! Ozone temperature factor table 1 R&Di
+ real(r8) tmp1 ! Ozone band factor see eq(A1) in R&Di
+ real(r8) u1 ! Effective ozone pathlength eq(A2) in R&Di
+ real(r8) realnu ! 1/beta factor in ozone band model eq(A1)
+ real(r8) tmp2 ! Ozone band factor see eq(A1) in R&Di
+ real(r8) u2 ! Effective ozone pathlength eq(A2) in R&Di
+ real(r8) rsqti ! Reciprocal of sqrt of path temperature
+ real(r8) tpath ! Path temperature used in co2 band model
+ real(r8) tmp3 ! Weak band factor see K&B
+ real(r8) rdpnmsq ! Reciprocal of difference in press^2
+ real(r8) rdpnm ! Reciprocal of difference in press
+ real(r8) p1 ! Mean pressure factor
+ real(r8) p2 ! Mean pressure factor
+ real(r8) dtym10 ! T - 260 used in eq(9) and (10) table A3a
+ real(r8) dplco2 ! Co2 path length
+ real(r8) te ! A_0 T factor in ozone model table 1 of R&Di
+ real(r8) denom ! Denominator in eq(r8) of table A3a of R&D
+ real(r8) th2o(pcols) ! transmission due to H2O
+ real(r8) tco2(pcols) ! transmission due to CO2
+ real(r8) to3(pcols) ! transmission due to O3
+!
+! Transmission terms for various spectral intervals:
+!
+ real(r8) trab2(pcols) ! H2o 500 - 800 cm-1
+ real(r8) absbnd ! Proportional to co2 band absorptance
+ real(r8) dbvtit(pcols,pverp)! Intrfc drvtv plnck fnctn for o3
+ real(r8) dbvtly(pcols,pver) ! Level drvtv plnck fnctn for o3
+!
+! Variables for Collins/Hackney/Edwards (C/H/E) &
+! Collins/Lee-Taylor/Edwards (C/LT/E) H2O parameterization
+
+!
+! Notation:
+! U = integral (P/P_0 dW) eq. 15 in Ramanathan/Downey 1986
+! P = atmospheric pressure
+! P_0 = reference atmospheric pressure
+! W = precipitable water path
+! T_e = emission temperature
+! T_p = path temperature
+! RH = path relative humidity
+!
+ real(r8) fa ! asymptotic value of abs. as U->infinity
+ real(r8) a_star ! normalized absorptivity for non-window
+ real(r8) l_star ! interpolated line transmission
+ real(r8) c_star ! interpolated continuum transmission
+
+ real(r8) te1 ! emission temperature
+ real(r8) te2 ! te^2
+ real(r8) te3 ! te^3
+ real(r8) te4 ! te^4
+ real(r8) te5 ! te^5
+
+ real(r8) log_u ! log base 10 of U
+ real(r8) log_uc ! log base 10 of H2O continuum path
+ real(r8) log_p ! log base 10 of P
+ real(r8) t_p ! T_p
+ real(r8) t_e ! T_e (offset by T_p)
+
+ integer iu ! index for log10(U)
+ integer iu1 ! iu + 1
+ integer iuc ! index for log10(H2O continuum path)
+ integer iuc1 ! iuc + 1
+ integer ip ! index for log10(P)
+ integer ip1 ! ip + 1
+ integer itp ! index for T_p
+ integer itp1 ! itp + 1
+ integer ite ! index for T_e
+ integer ite1 ! ite + 1
+ integer irh ! index for RH
+ integer irh1 ! irh + 1
+
+ real(r8) dvar ! normalized variation in T_p/T_e/P/U
+ real(r8) uvar ! U * diffusivity factor
+ real(r8) uscl ! factor for lineary scaling as U->0
+
+ real(r8) wu ! weight for U
+ real(r8) wu1 ! 1 - wu
+ real(r8) wuc ! weight for H2O continuum path
+ real(r8) wuc1 ! 1 - wuc
+ real(r8) wp ! weight for P
+ real(r8) wp1 ! 1 - wp
+ real(r8) wtp ! weight for T_p
+ real(r8) wtp1 ! 1 - wtp
+ real(r8) wte ! weight for T_e
+ real(r8) wte1 ! 1 - wte
+ real(r8) wrh ! weight for RH
+ real(r8) wrh1 ! 1 - wrh
+
+ real(r8) w_0_0_ ! weight for Tp/Te combination
+ real(r8) w_0_1_ ! weight for Tp/Te combination
+ real(r8) w_1_0_ ! weight for Tp/Te combination
+ real(r8) w_1_1_ ! weight for Tp/Te combination
+
+ real(r8) w_0_00 ! weight for Tp/Te/RH combination
+ real(r8) w_0_01 ! weight for Tp/Te/RH combination
+ real(r8) w_0_10 ! weight for Tp/Te/RH combination
+ real(r8) w_0_11 ! weight for Tp/Te/RH combination
+ real(r8) w_1_00 ! weight for Tp/Te/RH combination
+ real(r8) w_1_01 ! weight for Tp/Te/RH combination
+ real(r8) w_1_10 ! weight for Tp/Te/RH combination
+ real(r8) w_1_11 ! weight for Tp/Te/RH combination
+
+ real(r8) w00_00 ! weight for P/Tp/Te/RH combination
+ real(r8) w00_01 ! weight for P/Tp/Te/RH combination
+ real(r8) w00_10 ! weight for P/Tp/Te/RH combination
+ real(r8) w00_11 ! weight for P/Tp/Te/RH combination
+ real(r8) w01_00 ! weight for P/Tp/Te/RH combination
+ real(r8) w01_01 ! weight for P/Tp/Te/RH combination
+ real(r8) w01_10 ! weight for P/Tp/Te/RH combination
+ real(r8) w01_11 ! weight for P/Tp/Te/RH combination
+ real(r8) w10_00 ! weight for P/Tp/Te/RH combination
+ real(r8) w10_01 ! weight for P/Tp/Te/RH combination
+ real(r8) w10_10 ! weight for P/Tp/Te/RH combination
+ real(r8) w10_11 ! weight for P/Tp/Te/RH combination
+ real(r8) w11_00 ! weight for P/Tp/Te/RH combination
+ real(r8) w11_01 ! weight for P/Tp/Te/RH combination
+ real(r8) w11_10 ! weight for P/Tp/Te/RH combination
+ real(r8) w11_11 ! weight for P/Tp/Te/RH combination
+
+ integer ib ! spectral interval:
+ ! 1 = 0-800 cm^-1 and 1200-2200 cm^-1
+ ! 2 = 800-1200 cm^-1
+
+
+ real(r8) pch2o ! H2O continuum path
+ real(r8) fch2o ! temp. factor for continuum
+ real(r8) uch2o ! U corresponding to H2O cont. path (window)
+
+ real(r8) fdif ! secant(zenith angle) for diffusivity approx.
+
+ real(r8) sslp_mks ! Sea-level pressure in MKS units
+ real(r8) esx ! saturation vapor pressure returned by vqsatd
+ real(r8) qsx ! saturation mixing ratio returned by vqsatd
+ real(r8) pnew_mks ! pnew in MKS units
+ real(r8) q_path ! effective specific humidity along path
+ real(r8) rh_path ! effective relative humidity along path
+ real(r8) omeps ! 1 - epsilo
+
+ integer iest ! index in estblh2o
+
+ integer bnd_idx ! LW band index
+ real(r8) aer_pth_dlt ! [kg m-2] STRAER path between interface levels k1 and k2
+ real(r8) aer_pth_ngh(pcols)
+ ! [kg m-2] STRAER path between neighboring layers
+ real(r8) odap_aer_ttl ! [fraction] Total path absorption optical depth
+ real(r8) aer_trn_ngh(pcols,bnd_nbr_LW)
+ ! [fraction] Total transmission between
+ ! nearest neighbor sub-levels
+!
+!--------------------------Statement function---------------------------
+!
+ real(r8) dbvt,t ! Planck fnctn tmp derivative for o3
+!
+ dbvt(t)=(-2.8911366682e-4+(2.3771251896e-6+1.1305188929e-10*t)*t)/ &
+ (1.0+(-6.1364820707e-3+1.5550319767e-5*t)*t)
+!
+!
+!-----------------------------------------------------------------------
+!
+! Initialize
+!
+ do k2=1,ntoplw-1
+ do k1=1,ntoplw-1
+ abstot(:,k1,k2) = inf ! set unused portions for lf95 restart write
+ end do
+ end do
+ do k2=1,4
+ do k1=1,ntoplw-1
+ absnxt(:,k1,k2) = inf ! set unused portions for lf95 restart write
+ end do
+ end do
+
+ do k=ntoplw,pverp
+ abstot(:,k,k) = inf ! set unused portions for lf95 restart write
+ end do
+
+ do k=ntoplw,pver
+ do i=1,ncol
+ dbvtly(i,k) = dbvt(tlayr(i,k+1))
+ dbvtit(i,k) = dbvt(tint(i,k))
+ end do
+ end do
+ do i=1,ncol
+ dbvtit(i,pverp) = dbvt(tint(i,pverp))
+ end do
+!
+ r293 = 1./293.
+ r250 = 1./250.
+ r3205 = 1./.3205
+ r300 = 1./300.
+ rsslp = 1./sslp
+ r2sslp = 1./(2.*sslp)
+!
+!Constants for computing U corresponding to H2O cont. path
+!
+ fdif = 1.66
+ sslp_mks = sslp / 10.0
+ omeps = 1.0 - epsilo
+!
+! Non-adjacent layer absorptivity:
+!
+! abso(i,1) 0 - 800 cm-1 h2o rotation band
+! abso(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band
+! abso(i,2) 800 - 1200 cm-1 h2o window
+!
+! Separation between rotation and vibration-rotation dropped, so
+! only 2 slots needed for H2O absorptivity
+!
+! 500-800 cm^-1 H2o continuum/line overlap already included
+! in abso(i,1). This used to be in abso(i,4)
+!
+! abso(i,3) o3 9.6 micrometer band (nu3 and nu1 bands)
+! abso(i,4) co2 15 micrometer band system
+!
+ do k=ntoplw,pverp
+ do i=1,ncol
+ pnmsq(i,k) = pnm(i,k)**2
+ dtx(i) = tplnka(i,k) - 250.
+ end do
+ end do
+!
+! Non-nearest layer level loops
+!
+ do k1=pverp,ntoplw,-1
+ do k2=pverp,ntoplw,-1
+ if (k1 == k2) cycle
+ do i=1,ncol
+ dplh2o(i) = plh2o(i,k1) - plh2o(i,k2)
+ u(i) = abs(dplh2o(i))
+ sqrtu(i) = sqrt(u(i))
+ ds2c = abs(s2c(i,k1) - s2c(i,k2))
+ dw(i) = abs(w(i,k1) - w(i,k2))
+ uc1(i) = (ds2c + 1.7e-3*u(i))*(1. + 2.*ds2c)/(1. + 15.*ds2c)
+ pch2o = ds2c
+ pnew(i) = u(i)/dw(i)
+ pnew_mks = pnew(i) * sslp_mks
+!
+! Changed effective path temperature to std. Curtis-Godson form
+!
+ tpatha = abs(tcg(i,k1) - tcg(i,k2))/dw(i)
+ t_p = min(max(tpatha, min_tp_h2o), max_tp_h2o)
+ iest = floor(t_p) - min_tp_h2o
+ esx = estblh2o(iest) + (estblh2o(iest+1)-estblh2o(iest)) * &
+ (t_p - min_tp_h2o - iest)
+ qsx = epsilo * esx / (pnew_mks - omeps * esx)
+!
+! Compute effective RH along path
+!
+ q_path = dw(i) / abs(pnm(i,k1) - pnm(i,k2)) / rga
+!
+! Calculate effective u, pnew for each band using
+! Hulst-Curtis-Godson approximation:
+! Formulae: Goody and Yung, Atmospheric Radiation: Theoretical Basis,
+! 2nd edition, Oxford University Press, 1989.
+! Effective H2O path (w)
+! eq. 6.24, p. 228
+! Effective H2O path pressure (pnew = u/w):
+! eq. 6.29, p. 228
+!
+ ub(1) = abs(plh2ob(1,i,k1) - plh2ob(1,i,k2)) / psi(t_p,1)
+ ub(2) = abs(plh2ob(2,i,k1) - plh2ob(2,i,k2)) / psi(t_p,2)
+
+ pnewb(1) = ub(1) / abs(wb(1,i,k1) - wb(1,i,k2)) * phi(t_p,1)
+ pnewb(2) = ub(2) / abs(wb(2,i,k1) - wb(2,i,k2)) * phi(t_p,2)
+
+ dtx(i) = tplnka(i,k2) - 250.
+ dty(i) = tpatha - 250.
+
+ fwk(i) = fwcoef + fwc1/(1. + fwc2*u(i))
+ fwku(i) = fwk(i)*u(i)
+!
+! Define variables for C/H/E (now C/LT/E) fit
+!
+! abso(i,1) 0 - 800 cm-1 h2o rotation band
+! abso(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band
+! abso(i,2) 800 - 1200 cm-1 h2o window
+!
+! Separation between rotation and vibration-rotation dropped, so
+! only 2 slots needed for H2O absorptivity
+!
+! Notation:
+! U = integral (P/P_0 dW)
+! P = atmospheric pressure
+! P_0 = reference atmospheric pressure
+! W = precipitable water path
+! T_e = emission temperature
+! T_p = path temperature
+! RH = path relative humidity
+!
+!
+! Terms for asymptotic value of emissivity
+!
+ te1 = tplnka(i,k2)
+ te2 = te1 * te1
+ te3 = te2 * te1
+ te4 = te3 * te1
+ te5 = te4 * te1
+
+!
+! Band-independent indices for lines and continuum tables
+!
+ dvar = (t_p - min_tp_h2o) / dtp_h2o
+ itp = min(max(int(aint(dvar,r8)) + 1, 1), n_tp - 1)
+ itp1 = itp + 1
+ wtp = dvar - floor(dvar)
+ wtp1 = 1.0 - wtp
+
+ t_e = min(max(tplnka(i,k2)-t_p, min_te_h2o), max_te_h2o)
+ dvar = (t_e - min_te_h2o) / dte_h2o
+ ite = min(max(int(aint(dvar,r8)) + 1, 1), n_te - 1)
+ ite1 = ite + 1
+ wte = dvar - floor(dvar)
+ wte1 = 1.0 - wte
+
+ rh_path = min(max(q_path / qsx, min_rh_h2o), max_rh_h2o)
+ dvar = (rh_path - min_rh_h2o) / drh_h2o
+ irh = min(max(int(aint(dvar,r8)) + 1, 1), n_rh - 1)
+ irh1 = irh + 1
+ wrh = dvar - floor(dvar)
+ wrh1 = 1.0 - wrh
+
+ w_0_0_ = wtp * wte
+ w_0_1_ = wtp * wte1
+ w_1_0_ = wtp1 * wte
+ w_1_1_ = wtp1 * wte1
+
+ w_0_00 = w_0_0_ * wrh
+ w_0_01 = w_0_0_ * wrh1
+ w_0_10 = w_0_1_ * wrh
+ w_0_11 = w_0_1_ * wrh1
+ w_1_00 = w_1_0_ * wrh
+ w_1_01 = w_1_0_ * wrh1
+ w_1_10 = w_1_1_ * wrh
+ w_1_11 = w_1_1_ * wrh1
+
+!
+! H2O Continuum path for 0-800 and 1200-2200 cm^-1
+!
+! Assume foreign continuum dominates total H2O continuum in these bands
+! per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776
+! Then the effective H2O path is just
+! U_c = integral[ f(P) dW ]
+! where
+! W = water-vapor mass and
+! f(P) = dependence of foreign continuum on pressure
+! = P / sslp
+! Then
+! U_c = U (the same effective H2O path as for lines)
+!
+!
+! Continuum terms for 800-1200 cm^-1
+!
+! Assume self continuum dominates total H2O continuum for this band
+! per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776
+! Then the effective H2O self-continuum path is
+! U_c = integral[ h(e,T) dW ] (*eq. 1*)
+! where
+! W = water-vapor mass and
+! e = partial pressure of H2O along path
+! T = temperature along path
+! h(e,T) = dependence of foreign continuum on e,T
+! = e / sslp * f(T)
+!
+! Replacing
+! e =~ q * P / epsilo
+! q = mixing ratio of H2O
+! epsilo = 0.622
+!
+! and using the definition
+! U = integral [ (P / sslp) dW ]
+! = (P / sslp) W (homogeneous path)
+!
+! the effective path length for the self continuum is
+! U_c = (q / epsilo) f(T) U (*eq. 2*)
+!
+! Once values of T, U, and q have been calculated for the inhomogeneous
+! path, this sets U_c for the corresponding
+! homogeneous atmosphere. However, this need not equal the
+! value of U_c' defined by eq. 1 for the actual inhomogeneous atmosphere
+! under consideration.
+!
+! Solution: hold T and q constant, solve for U' that gives U_c' by
+! inverting eq. (2):
+!
+! U' = (U_c * epsilo) / (q * f(T))
+!
+ fch2o = fh2oself(t_p)
+ uch2o = (pch2o * epsilo) / (q_path * fch2o)
+
+!
+! Band-dependent indices for non-window
+!
+ ib = 1
+
+ uvar = ub(ib) * fdif
+ log_u = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
+ dvar = (log_u - min_lu_h2o) / dlu_h2o
+ iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
+ iu1 = iu + 1
+ wu = dvar - floor(dvar)
+ wu1 = 1.0 - wu
+
+ log_p = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o)
+ dvar = (log_p - min_lp_h2o) / dlp_h2o
+ ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
+ ip1 = ip + 1
+ wp = dvar - floor(dvar)
+ wp1 = 1.0 - wp
+
+ w00_00 = wp * w_0_00
+ w00_01 = wp * w_0_01
+ w00_10 = wp * w_0_10
+ w00_11 = wp * w_0_11
+ w01_00 = wp * w_1_00
+ w01_01 = wp * w_1_01
+ w01_10 = wp * w_1_10
+ w01_11 = wp * w_1_11
+ w10_00 = wp1 * w_0_00
+ w10_01 = wp1 * w_0_01
+ w10_10 = wp1 * w_0_10
+ w10_11 = wp1 * w_0_11
+ w11_00 = wp1 * w_1_00
+ w11_01 = wp1 * w_1_01
+ w11_10 = wp1 * w_1_10
+ w11_11 = wp1 * w_1_11
+!
+! Asymptotic value of absorptivity as U->infinity
+!
+ fa = fat(1,ib) + &
+ fat(2,ib) * te1 + &
+ fat(3,ib) * te2 + &
+ fat(4,ib) * te3 + &
+ fat(5,ib) * te4 + &
+ fat(6,ib) * te5
+
+ a_star = &
+ ah2onw(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
+ ah2onw(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
+ ah2onw(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
+ ah2onw(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
+ ah2onw(ip , itp , iu1, ite , irh ) * w11_11 * wu + &
+ ah2onw(ip , itp , iu1, ite , irh1) * w11_10 * wu + &
+ ah2onw(ip , itp , iu1, ite1, irh ) * w11_01 * wu + &
+ ah2onw(ip , itp , iu1, ite1, irh1) * w11_00 * wu + &
+ ah2onw(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
+ ah2onw(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
+ ah2onw(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
+ ah2onw(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
+ ah2onw(ip , itp1, iu1, ite , irh ) * w10_11 * wu + &
+ ah2onw(ip , itp1, iu1, ite , irh1) * w10_10 * wu + &
+ ah2onw(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + &
+ ah2onw(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + &
+ ah2onw(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
+ ah2onw(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
+ ah2onw(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
+ ah2onw(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
+ ah2onw(ip1, itp , iu1, ite , irh ) * w01_11 * wu + &
+ ah2onw(ip1, itp , iu1, ite , irh1) * w01_10 * wu + &
+ ah2onw(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + &
+ ah2onw(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + &
+ ah2onw(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
+ ah2onw(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
+ ah2onw(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
+ ah2onw(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
+ ah2onw(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + &
+ ah2onw(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + &
+ ah2onw(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + &
+ ah2onw(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
+ abso(i,ib) = min(max(fa * (1.0 - (1.0 - a_star) * &
+ aer_trn_ttl(i,k1,k2,ib)), &
+ 0.0_r8), 1.0_r8)
+!
+! Invoke linear limit for scaling wrt u below min_u_h2o
+!
+ if (uvar < min_u_h2o) then
+ uscl = uvar / min_u_h2o
+ abso(i,ib) = abso(i,ib) * uscl
+ endif
+
+!
+! Band-dependent indices for window
+!
+ ib = 2
+
+ uvar = ub(ib) * fdif
+ log_u = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
+ dvar = (log_u - min_lu_h2o) / dlu_h2o
+ iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
+ iu1 = iu + 1
+ wu = dvar - floor(dvar)
+ wu1 = 1.0 - wu
+
+ log_p = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o)
+ dvar = (log_p - min_lp_h2o) / dlp_h2o
+ ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
+ ip1 = ip + 1
+ wp = dvar - floor(dvar)
+ wp1 = 1.0 - wp
+
+ w00_00 = wp * w_0_00
+ w00_01 = wp * w_0_01
+ w00_10 = wp * w_0_10
+ w00_11 = wp * w_0_11
+ w01_00 = wp * w_1_00
+ w01_01 = wp * w_1_01
+ w01_10 = wp * w_1_10
+ w01_11 = wp * w_1_11
+ w10_00 = wp1 * w_0_00
+ w10_01 = wp1 * w_0_01
+ w10_10 = wp1 * w_0_10
+ w10_11 = wp1 * w_0_11
+ w11_00 = wp1 * w_1_00
+ w11_01 = wp1 * w_1_01
+ w11_10 = wp1 * w_1_10
+ w11_11 = wp1 * w_1_11
+
+ log_uc = min(log10(max(uch2o * fdif, min_u_h2o)), max_lu_h2o)
+ dvar = (log_uc - min_lu_h2o) / dlu_h2o
+ iuc = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
+ iuc1 = iuc + 1
+ wuc = dvar - floor(dvar)
+ wuc1 = 1.0 - wuc
+!
+! Asymptotic value of absorptivity as U->infinity
+!
+ fa = fat(1,ib) + &
+ fat(2,ib) * te1 + &
+ fat(3,ib) * te2 + &
+ fat(4,ib) * te3 + &
+ fat(5,ib) * te4 + &
+ fat(6,ib) * te5
+
+ l_star = &
+ ln_ah2ow(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
+ ln_ah2ow(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
+ ln_ah2ow(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
+ ln_ah2ow(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
+ ln_ah2ow(ip , itp , iu1, ite , irh ) * w11_11 * wu + &
+ ln_ah2ow(ip , itp , iu1, ite , irh1) * w11_10 * wu + &
+ ln_ah2ow(ip , itp , iu1, ite1, irh ) * w11_01 * wu + &
+ ln_ah2ow(ip , itp , iu1, ite1, irh1) * w11_00 * wu + &
+ ln_ah2ow(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
+ ln_ah2ow(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
+ ln_ah2ow(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
+ ln_ah2ow(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
+ ln_ah2ow(ip , itp1, iu1, ite , irh ) * w10_11 * wu + &
+ ln_ah2ow(ip , itp1, iu1, ite , irh1) * w10_10 * wu + &
+ ln_ah2ow(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + &
+ ln_ah2ow(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + &
+ ln_ah2ow(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
+ ln_ah2ow(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
+ ln_ah2ow(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
+ ln_ah2ow(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
+ ln_ah2ow(ip1, itp , iu1, ite , irh ) * w01_11 * wu + &
+ ln_ah2ow(ip1, itp , iu1, ite , irh1) * w01_10 * wu + &
+ ln_ah2ow(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + &
+ ln_ah2ow(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + &
+ ln_ah2ow(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
+ ln_ah2ow(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
+ ln_ah2ow(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
+ ln_ah2ow(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
+ ln_ah2ow(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + &
+ ln_ah2ow(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + &
+ ln_ah2ow(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + &
+ ln_ah2ow(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
+
+ c_star = &
+ cn_ah2ow(ip , itp , iuc , ite , irh ) * w11_11 * wuc1 + &
+ cn_ah2ow(ip , itp , iuc , ite , irh1) * w11_10 * wuc1 + &
+ cn_ah2ow(ip , itp , iuc , ite1, irh ) * w11_01 * wuc1 + &
+ cn_ah2ow(ip , itp , iuc , ite1, irh1) * w11_00 * wuc1 + &
+ cn_ah2ow(ip , itp , iuc1, ite , irh ) * w11_11 * wuc + &
+ cn_ah2ow(ip , itp , iuc1, ite , irh1) * w11_10 * wuc + &
+ cn_ah2ow(ip , itp , iuc1, ite1, irh ) * w11_01 * wuc + &
+ cn_ah2ow(ip , itp , iuc1, ite1, irh1) * w11_00 * wuc + &
+ cn_ah2ow(ip , itp1, iuc , ite , irh ) * w10_11 * wuc1 + &
+ cn_ah2ow(ip , itp1, iuc , ite , irh1) * w10_10 * wuc1 + &
+ cn_ah2ow(ip , itp1, iuc , ite1, irh ) * w10_01 * wuc1 + &
+ cn_ah2ow(ip , itp1, iuc , ite1, irh1) * w10_00 * wuc1 + &
+ cn_ah2ow(ip , itp1, iuc1, ite , irh ) * w10_11 * wuc + &
+ cn_ah2ow(ip , itp1, iuc1, ite , irh1) * w10_10 * wuc + &
+ cn_ah2ow(ip , itp1, iuc1, ite1, irh ) * w10_01 * wuc + &
+ cn_ah2ow(ip , itp1, iuc1, ite1, irh1) * w10_00 * wuc + &
+ cn_ah2ow(ip1, itp , iuc , ite , irh ) * w01_11 * wuc1 + &
+ cn_ah2ow(ip1, itp , iuc , ite , irh1) * w01_10 * wuc1 + &
+ cn_ah2ow(ip1, itp , iuc , ite1, irh ) * w01_01 * wuc1 + &
+ cn_ah2ow(ip1, itp , iuc , ite1, irh1) * w01_00 * wuc1 + &
+ cn_ah2ow(ip1, itp , iuc1, ite , irh ) * w01_11 * wuc + &
+ cn_ah2ow(ip1, itp , iuc1, ite , irh1) * w01_10 * wuc + &
+ cn_ah2ow(ip1, itp , iuc1, ite1, irh ) * w01_01 * wuc + &
+ cn_ah2ow(ip1, itp , iuc1, ite1, irh1) * w01_00 * wuc + &
+ cn_ah2ow(ip1, itp1, iuc , ite , irh ) * w00_11 * wuc1 + &
+ cn_ah2ow(ip1, itp1, iuc , ite , irh1) * w00_10 * wuc1 + &
+ cn_ah2ow(ip1, itp1, iuc , ite1, irh ) * w00_01 * wuc1 + &
+ cn_ah2ow(ip1, itp1, iuc , ite1, irh1) * w00_00 * wuc1 + &
+ cn_ah2ow(ip1, itp1, iuc1, ite , irh ) * w00_11 * wuc + &
+ cn_ah2ow(ip1, itp1, iuc1, ite , irh1) * w00_10 * wuc + &
+ cn_ah2ow(ip1, itp1, iuc1, ite1, irh ) * w00_01 * wuc + &
+ cn_ah2ow(ip1, itp1, iuc1, ite1, irh1) * w00_00 * wuc
+ abso(i,ib) = min(max(fa * (1.0 - l_star * c_star * &
+ aer_trn_ttl(i,k1,k2,ib)), &
+ 0.0_r8), 1.0_r8)
+!
+! Invoke linear limit for scaling wrt u below min_u_h2o
+!
+ if (uvar < min_u_h2o) then
+ uscl = uvar / min_u_h2o
+ abso(i,ib) = abso(i,ib) * uscl
+ endif
+
+ end do
+!
+! Line transmission in 800-1000 and 1000-1200 cm-1 intervals
+!
+ do i=1,ncol
+ term7(i,1) = coefj(1,1) + coefj(2,1)*dty(i)*(1. + c16*dty(i))
+ term8(i,1) = coefk(1,1) + coefk(2,1)*dty(i)*(1. + c17*dty(i))
+ term7(i,2) = coefj(1,2) + coefj(2,2)*dty(i)*(1. + c26*dty(i))
+ term8(i,2) = coefk(1,2) + coefk(2,2)*dty(i)*(1. + c27*dty(i))
+ end do
+!
+! 500 - 800 cm-1 h2o rotation band overlap with co2
+!
+ do i=1,ncol
+ k21 = term7(i,1) + term8(i,1)/ &
+ (1. + (c30 + c31*(dty(i)-10.)*(dty(i)-10.))*sqrtu(i))
+ k22 = term7(i,2) + term8(i,2)/ &
+ (1. + (c28 + c29*(dty(i)-10.))*sqrtu(i))
+ tr1 = exp(-(k21*(sqrtu(i) + fc1*fwku(i))))
+ tr2 = exp(-(k22*(sqrtu(i) + fc1*fwku(i))))
+ tr1=tr1*aer_trn_ttl(i,k1,k2,idx_LW_0650_0800)
+! ! H2O line+STRAER trn 650--800 cm-1
+ tr2=tr2*aer_trn_ttl(i,k1,k2,idx_LW_0500_0650)
+! ! H2O line+STRAER trn 500--650 cm-1
+ tr5 = exp(-((coefh(1,3) + coefh(2,3)*dtx(i))*uc1(i)))
+ tr6 = exp(-((coefh(1,4) + coefh(2,4)*dtx(i))*uc1(i)))
+ tr9(i) = tr1*tr5
+ tr10(i) = tr2*tr6
+ th2o(i) = tr10(i)
+ trab2(i) = 0.65*tr9(i) + 0.35*tr10(i)
+ end do
+ if (k2 < k1) then
+ do i=1,ncol
+ to3h2o(i) = h2otr(i,k1)/h2otr(i,k2)
+ end do
+ else
+ do i=1,ncol
+ to3h2o(i) = h2otr(i,k2)/h2otr(i,k1)
+ end do
+ end if
+!
+! abso(i,3) o3 9.6 micrometer band (nu3 and nu1 bands)
+!
+ do i=1,ncol
+ dpnm(i) = pnm(i,k1) - pnm(i,k2)
+ to3co2(i) = (pnm(i,k1)*co2t(i,k1) - pnm(i,k2)*co2t(i,k2))/dpnm(i)
+ te = (to3co2(i)*r293)**.7
+ dplos = plos(i,k1) - plos(i,k2)
+ dplol = plol(i,k1) - plol(i,k2)
+ u1 = 18.29*abs(dplos)/te
+ u2 = .5649*abs(dplos)/te
+ rphat = dplol/dplos
+ tlocal = tint(i,k2)
+ tcrfac = sqrt(tlocal*r250)*te
+ beta = r3205*(rphat + dpfo3*tcrfac)
+ realnu = te/beta
+ tmp1 = u1/sqrt(4. + u1*(1. + realnu))
+ tmp2 = u2/sqrt(4. + u2*(1. + realnu))
+ o3bndi = 74.*te*log(1. + tmp1 + tmp2)
+ abso(i,3) = o3bndi*to3h2o(i)*dbvtit(i,k2)
+ to3(i) = 1.0/(1. + 0.1*tmp1 + 0.1*tmp2)
+ end do
+!
+! abso(i,4) co2 15 micrometer band system
+!
+ do i=1,ncol
+ sqwp = sqrt(abs(plco2(i,k1) - plco2(i,k2)))
+ et = exp(-480./to3co2(i))
+ sqti(i) = sqrt(to3co2(i))
+ rsqti = 1./sqti(i)
+ et2 = et*et
+ et4 = et2*et2
+ omet = 1. - 1.5*et2
+ f1co2 = 899.70*omet*(1. + 1.94774*et + 4.73486*et2)*rsqti
+ f1sqwp(i) = f1co2*sqwp
+ t1co2(i) = 1./(1. + (245.18*omet*sqwp*rsqti))
+ oneme = 1. - et2
+ alphat = oneme**3*rsqti
+ pi = abs(dpnm(i))
+ wco2 = 2.5221*co2vmr*pi*rga
+ u7(i) = 4.9411e4*alphat*et2*wco2
+ u8 = 3.9744e4*alphat*et4*wco2
+ u9 = 1.0447e5*alphat*et4*et2*wco2
+ u13 = 2.8388e3*alphat*et4*wco2
+ tpath = to3co2(i)
+ tlocal = tint(i,k2)
+ tcrfac = sqrt(tlocal*r250*tpath*r300)
+ posqt = ((pnm(i,k2) + pnm(i,k1))*r2sslp + dpfco2*tcrfac)*rsqti
+ rbeta7(i) = 1./(5.3228*posqt)
+ rbeta8 = 1./(10.6576*posqt)
+ rbeta9 = rbeta7(i)
+ rbeta13 = rbeta9
+ f2co2(i) = (u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i)))) + &
+ (u8 /sqrt(4. + u8*(1. + rbeta8))) + &
+ (u9 /sqrt(4. + u9*(1. + rbeta9)))
+ f3co2(i) = u13/sqrt(4. + u13*(1. + rbeta13))
+ end do
+ if (k2 >= k1) then
+ do i=1,ncol
+ sqti(i) = sqrt(tlayr(i,k2))
+ end do
+ end if
+!
+ do i=1,ncol
+ tmp1 = log(1. + f1sqwp(i))
+ tmp2 = log(1. + f2co2(i))
+ tmp3 = log(1. + f3co2(i))
+ absbnd = (tmp1 + 2.*t1co2(i)*tmp2 + 2.*tmp3)*sqti(i)
+ abso(i,4) = trab2(i)*co2em(i,k2)*absbnd
+ tco2(i) = 1./(1.0+10.0*(u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i)))))
+ end do
+!
+! Calculate absorptivity due to trace gases, abstrc
+!
+ call trcab( lchnk ,ncol ,pcols, pverp, &
+ k1 ,k2 ,ucfc11 ,ucfc12 ,un2o0 , &
+ un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , &
+ uco221 ,uco222 ,uco223 ,bn2o0 ,bn2o1 , &
+ bch4 ,to3co2 ,pnm ,dw ,pnew , &
+ s2c ,uptype ,u ,abplnk1 ,tco2 , &
+ th2o ,to3 ,abstrc , &
+ aer_trn_ttl)
+!
+! Sum total absorptivity
+!
+ do i=1,ncol
+ abstot(i,k1,k2) = abso(i,1) + abso(i,2) + &
+ abso(i,3) + abso(i,4) + abstrc(i)
+ end do
+ end do ! do k2 =
+ end do ! do k1 =
+!
+! Adjacent layer absorptivity:
+!
+! abso(i,1) 0 - 800 cm-1 h2o rotation band
+! abso(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band
+! abso(i,2) 800 - 1200 cm-1 h2o window
+!
+! Separation between rotation and vibration-rotation dropped, so
+! only 2 slots needed for H2O absorptivity
+!
+! 500-800 cm^-1 H2o continuum/line overlap already included
+! in abso(i,1). This used to be in abso(i,4)
+!
+! abso(i,3) o3 9.6 micrometer band (nu3 and nu1 bands)
+! abso(i,4) co2 15 micrometer band system
+!
+! Nearest layer level loop
+!
+ do k2=pver,ntoplw,-1
+ do i=1,ncol
+ tbar(i,1) = 0.5*(tint(i,k2+1) + tlayr(i,k2+1))
+ emm(i,1) = 0.5*(co2em(i,k2+1) + co2eml(i,k2))
+ tbar(i,2) = 0.5*(tlayr(i,k2+1) + tint(i,k2))
+ emm(i,2) = 0.5*(co2em(i,k2) + co2eml(i,k2))
+ tbar(i,3) = 0.5*(tbar(i,2) + tbar(i,1))
+ emm(i,3) = emm(i,1)
+ tbar(i,4) = tbar(i,3)
+ emm(i,4) = emm(i,2)
+ o3emm(i,1) = 0.5*(dbvtit(i,k2+1) + dbvtly(i,k2))
+ o3emm(i,2) = 0.5*(dbvtit(i,k2) + dbvtly(i,k2))
+ o3emm(i,3) = o3emm(i,1)
+ o3emm(i,4) = o3emm(i,2)
+ temh2o(i,1) = tbar(i,1)
+ temh2o(i,2) = tbar(i,2)
+ temh2o(i,3) = tbar(i,1)
+ temh2o(i,4) = tbar(i,2)
+ dpnm(i) = pnm(i,k2+1) - pnm(i,k2)
+ end do
+!
+! Weighted Planck functions for trace gases
+!
+ do wvl = 1,14
+ do i = 1,ncol
+ bplnk(wvl,i,1) = 0.5*(abplnk1(wvl,i,k2+1) + abplnk2(wvl,i,k2))
+ bplnk(wvl,i,2) = 0.5*(abplnk1(wvl,i,k2) + abplnk2(wvl,i,k2))
+ bplnk(wvl,i,3) = bplnk(wvl,i,1)
+ bplnk(wvl,i,4) = bplnk(wvl,i,2)
+ end do
+ end do
+
+ do i=1,ncol
+ rdpnmsq = 1./(pnmsq(i,k2+1) - pnmsq(i,k2))
+ rdpnm = 1./dpnm(i)
+ p1 = .5*(pbr(i,k2) + pnm(i,k2+1))
+ p2 = .5*(pbr(i,k2) + pnm(i,k2 ))
+ uinpl(i,1) = (pnmsq(i,k2+1) - p1**2)*rdpnmsq
+ uinpl(i,2) = -(pnmsq(i,k2 ) - p2**2)*rdpnmsq
+ uinpl(i,3) = -(pnmsq(i,k2 ) - p1**2)*rdpnmsq
+ uinpl(i,4) = (pnmsq(i,k2+1) - p2**2)*rdpnmsq
+ winpl(i,1) = (.5*( pnm(i,k2+1) - pbr(i,k2)))*rdpnm
+ winpl(i,2) = (.5*(-pnm(i,k2 ) + pbr(i,k2)))*rdpnm
+ winpl(i,3) = (.5*( pnm(i,k2+1) + pbr(i,k2)) - pnm(i,k2 ))*rdpnm
+ winpl(i,4) = (.5*(-pnm(i,k2 ) - pbr(i,k2)) + pnm(i,k2+1))*rdpnm
+ tmp1 = 1./(piln(i,k2+1) - piln(i,k2))
+ tmp2 = piln(i,k2+1) - pmln(i,k2)
+ tmp3 = piln(i,k2 ) - pmln(i,k2)
+ zinpl(i,1) = (.5*tmp2 )*tmp1
+ zinpl(i,2) = ( - .5*tmp3)*tmp1
+ zinpl(i,3) = (.5*tmp2 - tmp3)*tmp1
+ zinpl(i,4) = ( tmp2 - .5*tmp3)*tmp1
+ pinpl(i,1) = 0.5*(p1 + pnm(i,k2+1))
+ pinpl(i,2) = 0.5*(p2 + pnm(i,k2 ))
+ pinpl(i,3) = 0.5*(p1 + pnm(i,k2 ))
+ pinpl(i,4) = 0.5*(p2 + pnm(i,k2+1))
+ if(strat_volcanic) then
+ aer_pth_ngh(i) = abs(aer_mpp(i,k2)-aer_mpp(i,k2+1))
+ endif
+ end do
+ do kn=1,4
+ do i=1,ncol
+ u(i) = uinpl(i,kn)*abs(plh2o(i,k2) - plh2o(i,k2+1))
+ sqrtu(i) = sqrt(u(i))
+ dw(i) = abs(w(i,k2) - w(i,k2+1))
+ pnew(i) = u(i)/(winpl(i,kn)*dw(i))
+ pnew_mks = pnew(i) * sslp_mks
+ t_p = min(max(tbar(i,kn), min_tp_h2o), max_tp_h2o)
+ iest = floor(t_p) - min_tp_h2o
+ esx = estblh2o(iest) + (estblh2o(iest+1)-estblh2o(iest)) * &
+ (t_p - min_tp_h2o - iest)
+ qsx = epsilo * esx / (pnew_mks - omeps * esx)
+ q_path = dw(i) / ABS(dpnm(i)) / rga
+
+ ds2c = abs(s2c(i,k2) - s2c(i,k2+1))
+ uc1(i) = uinpl(i,kn)*ds2c
+ pch2o = uc1(i)
+ uc1(i) = (uc1(i) + 1.7e-3*u(i))*(1. + 2.*uc1(i))/(1. + 15.*uc1(i))
+ dtx(i) = temh2o(i,kn) - 250.
+ dty(i) = tbar(i,kn) - 250.
+
+ fwk(i) = fwcoef + fwc1/(1. + fwc2*u(i))
+ fwku(i) = fwk(i)*u(i)
+
+ if(strat_volcanic) then
+ aer_pth_dlt=uinpl(i,kn)*aer_pth_ngh(i)
+
+ do bnd_idx=1,bnd_nbr_LW
+ odap_aer_ttl=abs_cff_mss_aer(bnd_idx) * aer_pth_dlt
+ aer_trn_ngh(i,bnd_idx)=exp(-fdif * odap_aer_ttl)
+ end do
+ else
+ aer_trn_ngh(i,:) = 1.0
+ endif
+
+!
+! Define variables for C/H/E (now C/LT/E) fit
+!
+! abso(i,1) 0 - 800 cm-1 h2o rotation band
+! abso(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band
+! abso(i,2) 800 - 1200 cm-1 h2o window
+!
+! Separation between rotation and vibration-rotation dropped, so
+! only 2 slots needed for H2O absorptivity
+!
+! Notation:
+! U = integral (P/P_0 dW)
+! P = atmospheric pressure
+! P_0 = reference atmospheric pressure
+! W = precipitable water path
+! T_e = emission temperature
+! T_p = path temperature
+! RH = path relative humidity
+!
+!
+! Terms for asymptotic value of emissivity
+!
+ te1 = temh2o(i,kn)
+ te2 = te1 * te1
+ te3 = te2 * te1
+ te4 = te3 * te1
+ te5 = te4 * te1
+
+!
+! Indices for lines and continuum tables
+! Note: because we are dealing with the nearest layer,
+! the Hulst-Curtis-Godson corrections
+! for inhomogeneous paths are not applied.
+!
+ uvar = u(i)*fdif
+ log_u = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
+ dvar = (log_u - min_lu_h2o) / dlu_h2o
+ iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
+ iu1 = iu + 1
+ wu = dvar - floor(dvar)
+ wu1 = 1.0 - wu
+
+ log_p = min(log10(max(pnew(i), min_p_h2o)), max_lp_h2o)
+ dvar = (log_p - min_lp_h2o) / dlp_h2o
+ ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
+ ip1 = ip + 1
+ wp = dvar - floor(dvar)
+ wp1 = 1.0 - wp
+
+ dvar = (t_p - min_tp_h2o) / dtp_h2o
+ itp = min(max(int(aint(dvar,r8)) + 1, 1), n_tp - 1)
+ itp1 = itp + 1
+ wtp = dvar - floor(dvar)
+ wtp1 = 1.0 - wtp
+
+ t_e = min(max(temh2o(i,kn)-t_p,min_te_h2o),max_te_h2o)
+ dvar = (t_e - min_te_h2o) / dte_h2o
+ ite = min(max(int(aint(dvar,r8)) + 1, 1), n_te - 1)
+ ite1 = ite + 1
+ wte = dvar - floor(dvar)
+ wte1 = 1.0 - wte
+
+ rh_path = min(max(q_path / qsx, min_rh_h2o), max_rh_h2o)
+ dvar = (rh_path - min_rh_h2o) / drh_h2o
+ irh = min(max(int(aint(dvar,r8)) + 1, 1), n_rh - 1)
+ irh1 = irh + 1
+ wrh = dvar - floor(dvar)
+ wrh1 = 1.0 - wrh
+
+ w_0_0_ = wtp * wte
+ w_0_1_ = wtp * wte1
+ w_1_0_ = wtp1 * wte
+ w_1_1_ = wtp1 * wte1
+
+ w_0_00 = w_0_0_ * wrh
+ w_0_01 = w_0_0_ * wrh1
+ w_0_10 = w_0_1_ * wrh
+ w_0_11 = w_0_1_ * wrh1
+ w_1_00 = w_1_0_ * wrh
+ w_1_01 = w_1_0_ * wrh1
+ w_1_10 = w_1_1_ * wrh
+ w_1_11 = w_1_1_ * wrh1
+
+ w00_00 = wp * w_0_00
+ w00_01 = wp * w_0_01
+ w00_10 = wp * w_0_10
+ w00_11 = wp * w_0_11
+ w01_00 = wp * w_1_00
+ w01_01 = wp * w_1_01
+ w01_10 = wp * w_1_10
+ w01_11 = wp * w_1_11
+ w10_00 = wp1 * w_0_00
+ w10_01 = wp1 * w_0_01
+ w10_10 = wp1 * w_0_10
+ w10_11 = wp1 * w_0_11
+ w11_00 = wp1 * w_1_00
+ w11_01 = wp1 * w_1_01
+ w11_10 = wp1 * w_1_10
+ w11_11 = wp1 * w_1_11
+
+!
+! Non-window absorptivity
+!
+ ib = 1
+
+ fa = fat(1,ib) + &
+ fat(2,ib) * te1 + &
+ fat(3,ib) * te2 + &
+ fat(4,ib) * te3 + &
+ fat(5,ib) * te4 + &
+ fat(6,ib) * te5
+
+ a_star = &
+ ah2onw(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
+ ah2onw(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
+ ah2onw(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
+ ah2onw(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
+ ah2onw(ip , itp , iu1, ite , irh ) * w11_11 * wu + &
+ ah2onw(ip , itp , iu1, ite , irh1) * w11_10 * wu + &
+ ah2onw(ip , itp , iu1, ite1, irh ) * w11_01 * wu + &
+ ah2onw(ip , itp , iu1, ite1, irh1) * w11_00 * wu + &
+ ah2onw(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
+ ah2onw(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
+ ah2onw(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
+ ah2onw(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
+ ah2onw(ip , itp1, iu1, ite , irh ) * w10_11 * wu + &
+ ah2onw(ip , itp1, iu1, ite , irh1) * w10_10 * wu + &
+ ah2onw(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + &
+ ah2onw(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + &
+ ah2onw(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
+ ah2onw(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
+ ah2onw(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
+ ah2onw(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
+ ah2onw(ip1, itp , iu1, ite , irh ) * w01_11 * wu + &
+ ah2onw(ip1, itp , iu1, ite , irh1) * w01_10 * wu + &
+ ah2onw(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + &
+ ah2onw(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + &
+ ah2onw(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
+ ah2onw(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
+ ah2onw(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
+ ah2onw(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
+ ah2onw(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + &
+ ah2onw(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + &
+ ah2onw(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + &
+ ah2onw(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
+
+ abso(i,ib) = min(max(fa * (1.0 - (1.0 - a_star) * &
+ aer_trn_ngh(i,ib)), &
+ 0.0_r8), 1.0_r8)
+
+!
+! Invoke linear limit for scaling wrt u below min_u_h2o
+!
+ if (uvar < min_u_h2o) then
+ uscl = uvar / min_u_h2o
+ abso(i,ib) = abso(i,ib) * uscl
+ endif
+
+!
+! Window absorptivity
+!
+ ib = 2
+
+ fa = fat(1,ib) + &
+ fat(2,ib) * te1 + &
+ fat(3,ib) * te2 + &
+ fat(4,ib) * te3 + &
+ fat(5,ib) * te4 + &
+ fat(6,ib) * te5
+
+ a_star = &
+ ah2ow(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
+ ah2ow(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
+ ah2ow(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
+ ah2ow(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
+ ah2ow(ip , itp , iu1, ite , irh ) * w11_11 * wu + &
+ ah2ow(ip , itp , iu1, ite , irh1) * w11_10 * wu + &
+ ah2ow(ip , itp , iu1, ite1, irh ) * w11_01 * wu + &
+ ah2ow(ip , itp , iu1, ite1, irh1) * w11_00 * wu + &
+ ah2ow(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
+ ah2ow(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
+ ah2ow(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
+ ah2ow(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
+ ah2ow(ip , itp1, iu1, ite , irh ) * w10_11 * wu + &
+ ah2ow(ip , itp1, iu1, ite , irh1) * w10_10 * wu + &
+ ah2ow(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + &
+ ah2ow(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + &
+ ah2ow(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
+ ah2ow(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
+ ah2ow(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
+ ah2ow(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
+ ah2ow(ip1, itp , iu1, ite , irh ) * w01_11 * wu + &
+ ah2ow(ip1, itp , iu1, ite , irh1) * w01_10 * wu + &
+ ah2ow(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + &
+ ah2ow(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + &
+ ah2ow(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
+ ah2ow(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
+ ah2ow(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
+ ah2ow(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
+ ah2ow(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + &
+ ah2ow(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + &
+ ah2ow(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + &
+ ah2ow(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
+
+ abso(i,ib) = min(max(fa * (1.0 - (1.0 - a_star) * &
+ aer_trn_ngh(i,ib)), &
+ 0.0_r8), 1.0_r8)
+
+!
+! Invoke linear limit for scaling wrt u below min_u_h2o
+!
+ if (uvar < min_u_h2o) then
+ uscl = uvar / min_u_h2o
+ abso(i,ib) = abso(i,ib) * uscl
+ endif
+
+ end do
+!
+! Line transmission in 800-1000 and 1000-1200 cm-1 intervals
+!
+ do i=1,ncol
+ term7(i,1) = coefj(1,1) + coefj(2,1)*dty(i)*(1. + c16*dty(i))
+ term8(i,1) = coefk(1,1) + coefk(2,1)*dty(i)*(1. + c17*dty(i))
+ term7(i,2) = coefj(1,2) + coefj(2,2)*dty(i)*(1. + c26*dty(i))
+ term8(i,2) = coefk(1,2) + coefk(2,2)*dty(i)*(1. + c27*dty(i))
+ end do
+!
+! 500 - 800 cm-1 h2o rotation band overlap with co2
+!
+ do i=1,ncol
+ dtym10 = dty(i) - 10.
+ denom = 1. + (c30 + c31*dtym10*dtym10)*sqrtu(i)
+ k21 = term7(i,1) + term8(i,1)/denom
+ denom = 1. + (c28 + c29*dtym10 )*sqrtu(i)
+ k22 = term7(i,2) + term8(i,2)/denom
+ tr1 = exp(-(k21*(sqrtu(i) + fc1*fwku(i))))
+ tr2 = exp(-(k22*(sqrtu(i) + fc1*fwku(i))))
+ tr1=tr1*aer_trn_ngh(i,idx_LW_0650_0800)
+! ! H2O line+STRAER trn 650--800 cm-1
+ tr2=tr2*aer_trn_ngh(i,idx_LW_0500_0650)
+! ! H2O line+STRAER trn 500--650 cm-1
+ tr5 = exp(-((coefh(1,3) + coefh(2,3)*dtx(i))*uc1(i)))
+ tr6 = exp(-((coefh(1,4) + coefh(2,4)*dtx(i))*uc1(i)))
+ tr9(i) = tr1*tr5
+ tr10(i) = tr2*tr6
+ trab2(i)= 0.65*tr9(i) + 0.35*tr10(i)
+ th2o(i) = tr10(i)
+ end do
+!
+! abso(i,3) o3 9.6 micrometer (nu3 and nu1 bands)
+!
+ do i=1,ncol
+ te = (tbar(i,kn)*r293)**.7
+ dplos = abs(plos(i,k2+1) - plos(i,k2))
+ u1 = zinpl(i,kn)*18.29*dplos/te
+ u2 = zinpl(i,kn)*.5649*dplos/te
+ tlocal = tbar(i,kn)
+ tcrfac = sqrt(tlocal*r250)*te
+ beta = r3205*(pinpl(i,kn)*rsslp + dpfo3*tcrfac)
+ realnu = te/beta
+ tmp1 = u1/sqrt(4. + u1*(1. + realnu))
+ tmp2 = u2/sqrt(4. + u2*(1. + realnu))
+ o3bndi = 74.*te*log(1. + tmp1 + tmp2)
+ abso(i,3) = o3bndi*o3emm(i,kn)*(h2otr(i,k2+1)/h2otr(i,k2))
+ to3(i) = 1.0/(1. + 0.1*tmp1 + 0.1*tmp2)
+ end do
+!
+! abso(i,4) co2 15 micrometer band system
+!
+ do i=1,ncol
+ dplco2 = plco2(i,k2+1) - plco2(i,k2)
+ sqwp = sqrt(uinpl(i,kn)*dplco2)
+ et = exp(-480./tbar(i,kn))
+ sqti(i) = sqrt(tbar(i,kn))
+ rsqti = 1./sqti(i)
+ et2 = et*et
+ et4 = et2*et2
+ omet = (1. - 1.5*et2)
+ f1co2 = 899.70*omet*(1. + 1.94774*et + 4.73486*et2)*rsqti
+ f1sqwp(i)= f1co2*sqwp
+ t1co2(i) = 1./(1. + (245.18*omet*sqwp*rsqti))
+ oneme = 1. - et2
+ alphat = oneme**3*rsqti
+ pi = abs(dpnm(i))*winpl(i,kn)
+ wco2 = 2.5221*co2vmr*pi*rga
+ u7(i) = 4.9411e4*alphat*et2*wco2
+ u8 = 3.9744e4*alphat*et4*wco2
+ u9 = 1.0447e5*alphat*et4*et2*wco2
+ u13 = 2.8388e3*alphat*et4*wco2
+ tpath = tbar(i,kn)
+ tlocal = tbar(i,kn)
+ tcrfac = sqrt((tlocal*r250)*(tpath*r300))
+ posqt = (pinpl(i,kn)*rsslp + dpfco2*tcrfac)*rsqti
+ rbeta7(i)= 1./(5.3228*posqt)
+ rbeta8 = 1./(10.6576*posqt)
+ rbeta9 = rbeta7(i)
+ rbeta13 = rbeta9
+ f2co2(i) = u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i))) + &
+ u8 /sqrt(4. + u8*(1. + rbeta8)) + &
+ u9 /sqrt(4. + u9*(1. + rbeta9))
+ f3co2(i) = u13/sqrt(4. + u13*(1. + rbeta13))
+ tmp1 = log(1. + f1sqwp(i))
+ tmp2 = log(1. + f2co2(i))
+ tmp3 = log(1. + f3co2(i))
+ absbnd = (tmp1 + 2.*t1co2(i)*tmp2 + 2.*tmp3)*sqti(i)
+ abso(i,4)= trab2(i)*emm(i,kn)*absbnd
+ tco2(i) = 1.0/(1.0+ 10.0*u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i))))
+ end do ! do i =
+!
+! Calculate trace gas absorptivity for nearest layer, abstrc
+!
+ call trcabn(lchnk ,ncol ,pcols, pverp, &
+ k2 ,kn ,ucfc11 ,ucfc12 ,un2o0 , &
+ un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , &
+ uco221 ,uco222 ,uco223 ,tbar ,bplnk , &
+ winpl ,pinpl ,tco2 ,th2o ,to3 , &
+ uptype ,dw ,s2c ,u ,pnew , &
+ abstrc ,uinpl , &
+ aer_trn_ngh)
+!
+! Total next layer absorptivity:
+!
+ do i=1,ncol
+ absnxt(i,k2,kn) = abso(i,1) + abso(i,2) + &
+ abso(i,3) + abso(i,4) + abstrc(i)
+ end do
+ end do ! do kn =
+ end do ! do k2 =
+
+ return
+end subroutine radabs
+
+
+
+subroutine radems(lchnk ,ncol ,pcols, pver, pverp, &
+ s2c ,tcg ,w ,tplnke ,plh2o , &
+ pnm ,plco2 ,tint ,tint4 ,tlayr , &
+ tlayr4 ,plol ,plos ,ucfc11 ,ucfc12 , &
+ un2o0 ,un2o1 ,uch4 ,uco211 ,uco212 , &
+ uco213 ,uco221 ,uco222 ,uco223 ,uptype , &
+ bn2o0 ,bn2o1 ,bch4 ,co2em ,co2eml , &
+ co2t ,h2otr ,abplnk1 ,abplnk2 ,emstot , &
+ plh2ob ,wb , &
+ aer_trn_ttl)
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Compute emissivity for H2O, CO2, O3, CH4, N2O, CFC11 and CFC12
+!
+! Method:
+! H2O .... Uses nonisothermal emissivity method for water vapor from
+! Ramanathan, V. and P.Downey, 1986: A Nonisothermal
+! Emissivity and Absorptivity Formulation for Water Vapor
+! Jouranl of Geophysical Research, vol. 91., D8, pp 8649-8666
+!
+! Implementation updated by Collins,Hackney, and Edwards 2001
+! using line-by-line calculations based upon Hitran 1996 and
+! CKD 2.1 for absorptivity and emissivity
+!
+! Implementation updated by Collins, Lee-Taylor, and Edwards (2003)
+! using line-by-line calculations based upon Hitran 2000 and
+! CKD 2.4 for absorptivity and emissivity
+!
+! CO2 .... Uses absorptance parameterization of the 15 micro-meter
+! (500 - 800 cm-1) band system of Carbon Dioxide, from
+! Kiehl, J.T. and B.P.Briegleb, 1991: A New Parameterization
+! of the Absorptance Due to the 15 micro-meter Band System
+! of Carbon Dioxide Jouranl of Geophysical Research,
+! vol. 96., D5, pp 9013-9019. Also includes the effects
+! of the 9.4 and 10.4 micron bands of CO2.
+!
+! O3 .... Uses absorptance parameterization of the 9.6 micro-meter
+! band system of ozone, from Ramanathan, V. and R. Dickinson,
+! 1979: The Role of stratospheric ozone in the zonal and
+! seasonal radiative energy balance of the earth-troposphere
+! system. Journal of the Atmospheric Sciences, Vol. 36,
+! pp 1084-1104
+!
+! ch4 .... Uses a broad band model for the 7.7 micron band of methane.
+!
+! n20 .... Uses a broad band model for the 7.8, 8.6 and 17.0 micron
+! bands of nitrous oxide
+!
+! cfc11 ... Uses a quasi-linear model for the 9.2, 10.7, 11.8 and 12.5
+! micron bands of CFC11
+!
+! cfc12 ... Uses a quasi-linear model for the 8.6, 9.1, 10.8 and 11.2
+! micron bands of CFC12
+!
+!
+! Computes individual emissivities, accounting for band overlap, and
+! sums to obtain the total.
+!
+! Author: W. Collins (H2O emissivity) and J. Kiehl
+!
+!-----------------------------------------------------------------------
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+ integer, intent(in) :: lchnk ! chunk identifier
+ integer, intent(in) :: ncol ! number of atmospheric columns
+ integer, intent(in) :: pcols, pver, pverp
+
+ real(r8), intent(in) :: s2c(pcols,pverp) ! H2o continuum path length
+ real(r8), intent(in) :: tcg(pcols,pverp) ! H2o-mass-wgted temp. (Curtis-Godson approx.)
+ real(r8), intent(in) :: w(pcols,pverp) ! H2o path length
+ real(r8), intent(in) :: tplnke(pcols) ! Layer planck temperature
+ real(r8), intent(in) :: plh2o(pcols,pverp) ! H2o prs wghted path length
+ real(r8), intent(in) :: pnm(pcols,pverp) ! Model interface pressure
+ real(r8), intent(in) :: plco2(pcols,pverp) ! Prs wghted path of co2
+ real(r8), intent(in) :: tint(pcols,pverp) ! Model interface temperatures
+ real(r8), intent(in) :: tint4(pcols,pverp) ! Tint to the 4th power
+ real(r8), intent(in) :: tlayr(pcols,pverp) ! K-1 model layer temperature
+ real(r8), intent(in) :: tlayr4(pcols,pverp) ! Tlayr to the 4th power
+ real(r8), intent(in) :: plol(pcols,pverp) ! Pressure wghtd ozone path
+ real(r8), intent(in) :: plos(pcols,pverp) ! Ozone path
+ real(r8), intent(in) :: plh2ob(nbands,pcols,pverp) ! Pressure weighted h2o path with
+ ! Hulst-Curtis-Godson temp. factor
+ ! for H2O bands
+ real(r8), intent(in) :: wb(nbands,pcols,pverp) ! H2o path length with
+ ! Hulst-Curtis-Godson temp. factor
+ ! for H2O bands
+
+ real(r8), intent(in) :: aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW)
+! ! [fraction] Total strat. aerosol
+! ! transmission between interfaces k1 and k2
+
+!
+! Trace gas variables
+!
+ real(r8), intent(in) :: ucfc11(pcols,pverp) ! CFC11 path length
+ real(r8), intent(in) :: ucfc12(pcols,pverp) ! CFC12 path length
+ real(r8), intent(in) :: un2o0(pcols,pverp) ! N2O path length
+ real(r8), intent(in) :: un2o1(pcols,pverp) ! N2O path length (hot band)
+ real(r8), intent(in) :: uch4(pcols,pverp) ! CH4 path length
+ real(r8), intent(in) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length
+ real(r8), intent(in) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length
+ real(r8), intent(in) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length
+ real(r8), intent(in) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length
+ real(r8), intent(in) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length
+ real(r8), intent(in) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length
+ real(r8), intent(in) :: bn2o0(pcols,pverp) ! pressure factor for n2o
+ real(r8), intent(in) :: bn2o1(pcols,pverp) ! pressure factor for n2o
+ real(r8), intent(in) :: bch4(pcols,pverp) ! pressure factor for ch4
+ real(r8), intent(in) :: uptype(pcols,pverp) ! p-type continuum path length
+!
+! Output arguments
+!
+ real(r8), intent(out) :: emstot(pcols,pverp) ! Total emissivity
+ real(r8), intent(out) :: co2em(pcols,pverp) ! Layer co2 normalzd plnck funct drvtv
+ real(r8), intent(out) :: co2eml(pcols,pver) ! Intrfc co2 normalzd plnck func drvtv
+ real(r8), intent(out) :: co2t(pcols,pverp) ! Tmp and prs weighted path length
+ real(r8), intent(out) :: h2otr(pcols,pverp) ! H2o transmission over o3 band
+ real(r8), intent(out) :: abplnk1(14,pcols,pverp) ! non-nearest layer Plack factor
+ real(r8), intent(out) :: abplnk2(14,pcols,pverp) ! nearest layer factor
+
+!
+!---------------------------Local variables-----------------------------
+!
+ integer i ! Longitude index
+ integer k ! Level index]
+ integer k1 ! Level index
+!
+! Local variables for H2O:
+!
+ real(r8) h2oems(pcols,pverp) ! H2o emissivity
+ real(r8) tpathe ! Used to compute h2o emissivity
+ real(r8) dtx(pcols) ! Planck temperature minus 250 K
+ real(r8) dty(pcols) ! Path temperature minus 250 K
+!
+! The 500-800 cm^-1 emission in emis(i,4) has been combined
+! into the 0-800 cm^-1 emission in emis(i,1)
+!
+ real(r8) emis(pcols,2) ! H2O emissivity
+!
+!
+!
+ real(r8) term7(pcols,2) ! Kl_inf(i) in eq(r8) of table A3a of R&D
+ real(r8) term8(pcols,2) ! Delta kl_inf(i) in eq(r8)
+ real(r8) tr1(pcols) ! Equation(6) in table A2 for 650-800
+ real(r8) tr2(pcols) ! Equation(6) in table A2 for 500-650
+ real(r8) tr3(pcols) ! Equation(4) in table A2 for 650-800
+ real(r8) tr4(pcols) ! Equation(4),table A2 of R&D for 500-650
+ real(r8) tr7(pcols) ! Equation (6) times eq(4) in table A2
+! of R&D for 650-800 cm-1 region
+ real(r8) tr8(pcols) ! Equation (6) times eq(4) in table A2
+! of R&D for 500-650 cm-1 region
+ real(r8) k21(pcols) ! Exponential coefficient used to calc
+! rot band transmissivity in the 650-800
+! cm-1 region (tr1)
+ real(r8) k22(pcols) ! Exponential coefficient used to calc
+! rot band transmissivity in the 500-650
+! cm-1 region (tr2)
+ real(r8) u(pcols) ! Pressure weighted H2O path length
+ real(r8) ub(nbands) ! Pressure weighted H2O path length with
+ ! Hulst-Curtis-Godson correction for
+ ! each band
+ real(r8) pnew ! Effective pressure for h2o linewidth
+ real(r8) pnewb(nbands) ! Effective pressure for h2o linewidth w/
+ ! Hulst-Curtis-Godson correction for
+ ! each band
+ real(r8) uc1(pcols) ! H2o continuum pathlength 500-800 cm-1
+ real(r8) fwk ! Equation(33) in R&D far wing correction
+ real(r8) troco2(pcols,pverp) ! H2o overlap factor for co2 absorption
+ real(r8) emplnk(14,pcols) ! emissivity Planck factor
+ real(r8) emstrc(pcols,pverp) ! total trace gas emissivity
+!
+! Local variables for CO2:
+!
+ real(r8) co2ems(pcols,pverp) ! Co2 emissivity
+ real(r8) co2plk(pcols) ! Used to compute co2 emissivity
+ real(r8) sum(pcols) ! Used to calculate path temperature
+ real(r8) t1i ! Co2 hot band temperature factor
+ real(r8) sqti ! Sqrt of temperature
+ real(r8) pi ! Pressure used in co2 mean line width
+ real(r8) et ! Co2 hot band factor
+ real(r8) et2 ! Co2 hot band factor
+ real(r8) et4 ! Co2 hot band factor
+ real(r8) omet ! Co2 stimulated emission term
+ real(r8) ex ! Part of co2 planck function
+ real(r8) f1co2 ! Co2 weak band factor
+ real(r8) f2co2 ! Co2 weak band factor
+ real(r8) f3co2 ! Co2 weak band factor
+ real(r8) t1co2 ! Overlap factor weak bands strong band
+ real(r8) sqwp ! Sqrt of co2 pathlength
+ real(r8) f1sqwp ! Main co2 band factor
+ real(r8) oneme ! Co2 stimulated emission term
+ real(r8) alphat ! Part of the co2 stimulated emiss term
+ real(r8) wco2 ! Consts used to define co2 pathlength
+ real(r8) posqt ! Effective pressure for co2 line width
+ real(r8) rbeta7 ! Inverse of co2 hot band line width par
+ real(r8) rbeta8 ! Inverse of co2 hot band line width par
+ real(r8) rbeta9 ! Inverse of co2 hot band line width par
+ real(r8) rbeta13 ! Inverse of co2 hot band line width par
+ real(r8) tpath ! Path temp used in co2 band model
+ real(r8) tmp1 ! Co2 band factor
+ real(r8) tmp2 ! Co2 band factor
+ real(r8) tmp3 ! Co2 band factor
+ real(r8) tlayr5 ! Temperature factor in co2 Planck func
+ real(r8) rsqti ! Reciprocal of sqrt of temperature
+ real(r8) exm1sq ! Part of co2 Planck function
+ real(r8) u7 ! Absorber amt for various co2 band systems
+ real(r8) u8 ! Absorber amt for various co2 band systems
+ real(r8) u9 ! Absorber amt for various co2 band systems
+ real(r8) u13 ! Absorber amt for various co2 band systems
+ real(r8) r250 ! Inverse 250K
+ real(r8) r300 ! Inverse 300K
+ real(r8) rsslp ! Inverse standard sea-level pressure
+!
+! Local variables for O3:
+!
+ real(r8) o3ems(pcols,pverp) ! Ozone emissivity
+ real(r8) dbvtt(pcols) ! Tmp drvtv of planck fctn for tplnke
+ real(r8) dbvt,fo3,t,ux,vx
+ real(r8) te ! Temperature factor
+ real(r8) u1 ! Path length factor
+ real(r8) u2 ! Path length factor
+ real(r8) phat ! Effecitive path length pressure
+ real(r8) tlocal ! Local planck function temperature
+ real(r8) tcrfac ! Scaled temperature factor
+ real(r8) beta ! Absorption funct factor voigt effect
+ real(r8) realnu ! Absorption function factor
+ real(r8) o3bndi ! Band absorption factor
+!
+! Transmission terms for various spectral intervals:
+!
+ real(r8) absbnd ! Proportional to co2 band absorptance
+ real(r8) tco2(pcols) ! co2 overlap factor
+ real(r8) th2o(pcols) ! h2o overlap factor
+ real(r8) to3(pcols) ! o3 overlap factor
+!
+! Variables for new H2O parameterization
+!
+! Notation:
+! U = integral (P/P_0 dW) eq. 15 in Ramanathan/Downey 1986
+! P = atmospheric pressure
+! P_0 = reference atmospheric pressure
+! W = precipitable water path
+! T_e = emission temperature
+! T_p = path temperature
+! RH = path relative humidity
+!
+ real(r8) fe ! asymptotic value of emis. as U->infinity
+ real(r8) e_star ! normalized non-window emissivity
+ real(r8) l_star ! interpolated line transmission
+ real(r8) c_star ! interpolated continuum transmission
+
+ real(r8) te1 ! emission temperature
+ real(r8) te2 ! te^2
+ real(r8) te3 ! te^3
+ real(r8) te4 ! te^4
+ real(r8) te5 ! te^5
+
+ real(r8) log_u ! log base 10 of U
+ real(r8) log_uc ! log base 10 of H2O continuum path
+ real(r8) log_p ! log base 10 of P
+ real(r8) t_p ! T_p
+ real(r8) t_e ! T_e (offset by T_p)
+
+ integer iu ! index for log10(U)
+ integer iu1 ! iu + 1
+ integer iuc ! index for log10(H2O continuum path)
+ integer iuc1 ! iuc + 1
+ integer ip ! index for log10(P)
+ integer ip1 ! ip + 1
+ integer itp ! index for T_p
+ integer itp1 ! itp + 1
+ integer ite ! index for T_e
+ integer ite1 ! ite + 1
+ integer irh ! index for RH
+ integer irh1 ! irh + 1
+
+ real(r8) dvar ! normalized variation in T_p/T_e/P/U
+ real(r8) uvar ! U * diffusivity factor
+ real(r8) uscl ! factor for lineary scaling as U->0
+
+ real(r8) wu ! weight for U
+ real(r8) wu1 ! 1 - wu
+ real(r8) wuc ! weight for H2O continuum path
+ real(r8) wuc1 ! 1 - wuc
+ real(r8) wp ! weight for P
+ real(r8) wp1 ! 1 - wp
+ real(r8) wtp ! weight for T_p
+ real(r8) wtp1 ! 1 - wtp
+ real(r8) wte ! weight for T_e
+ real(r8) wte1 ! 1 - wte
+ real(r8) wrh ! weight for RH
+ real(r8) wrh1 ! 1 - wrh
+
+ real(r8) w_0_0_ ! weight for Tp/Te combination
+ real(r8) w_0_1_ ! weight for Tp/Te combination
+ real(r8) w_1_0_ ! weight for Tp/Te combination
+ real(r8) w_1_1_ ! weight for Tp/Te combination
+
+ real(r8) w_0_00 ! weight for Tp/Te/RH combination
+ real(r8) w_0_01 ! weight for Tp/Te/RH combination
+ real(r8) w_0_10 ! weight for Tp/Te/RH combination
+ real(r8) w_0_11 ! weight for Tp/Te/RH combination
+ real(r8) w_1_00 ! weight for Tp/Te/RH combination
+ real(r8) w_1_01 ! weight for Tp/Te/RH combination
+ real(r8) w_1_10 ! weight for Tp/Te/RH combination
+ real(r8) w_1_11 ! weight for Tp/Te/RH combination
+
+ real(r8) w00_00 ! weight for P/Tp/Te/RH combination
+ real(r8) w00_01 ! weight for P/Tp/Te/RH combination
+ real(r8) w00_10 ! weight for P/Tp/Te/RH combination
+ real(r8) w00_11 ! weight for P/Tp/Te/RH combination
+ real(r8) w01_00 ! weight for P/Tp/Te/RH combination
+ real(r8) w01_01 ! weight for P/Tp/Te/RH combination
+ real(r8) w01_10 ! weight for P/Tp/Te/RH combination
+ real(r8) w01_11 ! weight for P/Tp/Te/RH combination
+ real(r8) w10_00 ! weight for P/Tp/Te/RH combination
+ real(r8) w10_01 ! weight for P/Tp/Te/RH combination
+ real(r8) w10_10 ! weight for P/Tp/Te/RH combination
+ real(r8) w10_11 ! weight for P/Tp/Te/RH combination
+ real(r8) w11_00 ! weight for P/Tp/Te/RH combination
+ real(r8) w11_01 ! weight for P/Tp/Te/RH combination
+ real(r8) w11_10 ! weight for P/Tp/Te/RH combination
+ real(r8) w11_11 ! weight for P/Tp/Te/RH combination
+
+ integer ib ! spectral interval:
+ ! 1 = 0-800 cm^-1 and 1200-2200 cm^-1
+ ! 2 = 800-1200 cm^-1
+
+ real(r8) pch2o ! H2O continuum path
+ real(r8) fch2o ! temp. factor for continuum
+ real(r8) uch2o ! U corresponding to H2O cont. path (window)
+
+ real(r8) fdif ! secant(zenith angle) for diffusivity approx.
+
+ real(r8) sslp_mks ! Sea-level pressure in MKS units
+ real(r8) esx ! saturation vapor pressure returned by vqsatd
+ real(r8) qsx ! saturation mixing ratio returned by vqsatd
+ real(r8) pnew_mks ! pnew in MKS units
+ real(r8) q_path ! effective specific humidity along path
+ real(r8) rh_path ! effective relative humidity along path
+ real(r8) omeps ! 1 - epsilo
+
+ integer iest ! index in estblh2o
+
+!
+!---------------------------Statement functions-------------------------
+!
+! Derivative of planck function at 9.6 micro-meter wavelength, and
+! an absorption function factor:
+!
+!
+ dbvt(t)=(-2.8911366682e-4+(2.3771251896e-6+1.1305188929e-10*t)*t)/ &
+ (1.0+(-6.1364820707e-3+1.5550319767e-5*t)*t)
+!
+ fo3(ux,vx)=ux/sqrt(4.+ux*(1.+vx))
+!
+!
+!
+!-----------------------------------------------------------------------
+!
+! Initialize
+!
+ r250 = 1./250.
+ r300 = 1./300.
+ rsslp = 1./sslp
+!
+! Constants for computing U corresponding to H2O cont. path
+!
+ fdif = 1.66
+ sslp_mks = sslp / 10.0
+ omeps = 1.0 - epsilo
+!
+! Planck function for co2
+!
+ do i=1,ncol
+ ex = exp(960./tplnke(i))
+ co2plk(i) = 5.e8/((tplnke(i)**4)*(ex - 1.))
+ co2t(i,ntoplw) = tplnke(i)
+ sum(i) = co2t(i,ntoplw)*pnm(i,ntoplw)
+ end do
+ k = ntoplw
+ do k1=pverp,ntoplw+1,-1
+ k = k + 1
+ do i=1,ncol
+ sum(i) = sum(i) + tlayr(i,k)*(pnm(i,k)-pnm(i,k-1))
+ ex = exp(960./tlayr(i,k1))
+ tlayr5 = tlayr(i,k1)*tlayr4(i,k1)
+ co2eml(i,k1-1) = 1.2e11*ex/(tlayr5*(ex - 1.)**2)
+ co2t(i,k) = sum(i)/pnm(i,k)
+ end do
+ end do
+!
+! Initialize planck function derivative for O3
+!
+ do i=1,ncol
+ dbvtt(i) = dbvt(tplnke(i))
+ end do
+!
+! Calculate trace gas Planck functions
+!
+ call trcplk(lchnk ,ncol ,pcols, pver, pverp, &
+ tint ,tlayr ,tplnke ,emplnk ,abplnk1 , &
+ abplnk2 )
+!
+! Interface loop
+!
+ do k1=ntoplw,pverp
+!
+! H2O emissivity
+!
+! emis(i,1) 0 - 800 cm-1 h2o rotation band
+! emis(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band
+! emis(i,2) 800 - 1200 cm-1 h2o window
+!
+! Separation between rotation and vibration-rotation dropped, so
+! only 2 slots needed for H2O emissivity
+!
+! emis(i,3) = 0.0
+!
+! For the p type continuum
+!
+ do i=1,ncol
+ u(i) = plh2o(i,k1)
+ pnew = u(i)/w(i,k1)
+ pnew_mks = pnew * sslp_mks
+!
+! Apply scaling factor for 500-800 continuum
+!
+ uc1(i) = (s2c(i,k1) + 1.7e-3*plh2o(i,k1))*(1. + 2.*s2c(i,k1))/ &
+ (1. + 15.*s2c(i,k1))
+ pch2o = s2c(i,k1)
+!
+! Changed effective path temperature to std. Curtis-Godson form
+!
+ tpathe = tcg(i,k1)/w(i,k1)
+ t_p = min(max(tpathe, min_tp_h2o), max_tp_h2o)
+ iest = floor(t_p) - min_tp_h2o
+ esx = estblh2o(iest) + (estblh2o(iest+1)-estblh2o(iest)) * &
+ (t_p - min_tp_h2o - iest)
+ qsx = epsilo * esx / (pnew_mks - omeps * esx)
+!
+! Compute effective RH along path
+!
+ q_path = w(i,k1) / pnm(i,k1) / rga
+!
+! Calculate effective u, pnew for each band using
+! Hulst-Curtis-Godson approximation:
+! Formulae: Goody and Yung, Atmospheric Radiation: Theoretical Basis,
+! 2nd edition, Oxford University Press, 1989.
+! Effective H2O path (w)
+! eq. 6.24, p. 228
+! Effective H2O path pressure (pnew = u/w):
+! eq. 6.29, p. 228
+!
+ ub(1) = plh2ob(1,i,k1) / psi(t_p,1)
+ ub(2) = plh2ob(2,i,k1) / psi(t_p,2)
+
+ pnewb(1) = ub(1) / wb(1,i,k1) * phi(t_p,1)
+ pnewb(2) = ub(2) / wb(2,i,k1) * phi(t_p,2)
+!
+!
+!
+ dtx(i) = tplnke(i) - 250.
+ dty(i) = tpathe - 250.
+!
+! Define variables for C/H/E (now C/LT/E) fit
+!
+! emis(i,1) 0 - 800 cm-1 h2o rotation band
+! emis(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band
+! emis(i,2) 800 - 1200 cm-1 h2o window
+!
+! Separation between rotation and vibration-rotation dropped, so
+! only 2 slots needed for H2O emissivity
+!
+! emis(i,3) = 0.0
+!
+! Notation:
+! U = integral (P/P_0 dW)
+! P = atmospheric pressure
+! P_0 = reference atmospheric pressure
+! W = precipitable water path
+! T_e = emission temperature
+! T_p = path temperature
+! RH = path relative humidity
+!
+! Terms for asymptotic value of emissivity
+!
+ te1 = tplnke(i)
+ te2 = te1 * te1
+ te3 = te2 * te1
+ te4 = te3 * te1
+ te5 = te4 * te1
+!
+! Band-independent indices for lines and continuum tables
+!
+ dvar = (t_p - min_tp_h2o) / dtp_h2o
+ itp = min(max(int(aint(dvar,r8)) + 1, 1), n_tp - 1)
+ itp1 = itp + 1
+ wtp = dvar - floor(dvar)
+ wtp1 = 1.0 - wtp
+
+ t_e = min(max(tplnke(i) - t_p, min_te_h2o), max_te_h2o)
+ dvar = (t_e - min_te_h2o) / dte_h2o
+ ite = min(max(int(aint(dvar,r8)) + 1, 1), n_te - 1)
+ ite1 = ite + 1
+ wte = dvar - floor(dvar)
+ wte1 = 1.0 - wte
+
+ rh_path = min(max(q_path / qsx, min_rh_h2o), max_rh_h2o)
+ dvar = (rh_path - min_rh_h2o) / drh_h2o
+ irh = min(max(int(aint(dvar,r8)) + 1, 1), n_rh - 1)
+ irh1 = irh + 1
+ wrh = dvar - floor(dvar)
+ wrh1 = 1.0 - wrh
+
+ w_0_0_ = wtp * wte
+ w_0_1_ = wtp * wte1
+ w_1_0_ = wtp1 * wte
+ w_1_1_ = wtp1 * wte1
+
+ w_0_00 = w_0_0_ * wrh
+ w_0_01 = w_0_0_ * wrh1
+ w_0_10 = w_0_1_ * wrh
+ w_0_11 = w_0_1_ * wrh1
+ w_1_00 = w_1_0_ * wrh
+ w_1_01 = w_1_0_ * wrh1
+ w_1_10 = w_1_1_ * wrh
+ w_1_11 = w_1_1_ * wrh1
+!
+! H2O Continuum path for 0-800 and 1200-2200 cm^-1
+!
+! Assume foreign continuum dominates total H2O continuum in these bands
+! per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776
+! Then the effective H2O path is just
+! U_c = integral[ f(P) dW ]
+! where
+! W = water-vapor mass and
+! f(P) = dependence of foreign continuum on pressure
+! = P / sslp
+! Then
+! U_c = U (the same effective H2O path as for lines)
+!
+!
+! Continuum terms for 800-1200 cm^-1
+!
+! Assume self continuum dominates total H2O continuum for this band
+! per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776
+! Then the effective H2O self-continuum path is
+! U_c = integral[ h(e,T) dW ] (*eq. 1*)
+! where
+! W = water-vapor mass and
+! e = partial pressure of H2O along path
+! T = temperature along path
+! h(e,T) = dependence of foreign continuum on e,T
+! = e / sslp * f(T)
+!
+! Replacing
+! e =~ q * P / epsilo
+! q = mixing ratio of H2O
+! epsilo = 0.622
+!
+! and using the definition
+! U = integral [ (P / sslp) dW ]
+! = (P / sslp) W (homogeneous path)
+!
+! the effective path length for the self continuum is
+! U_c = (q / epsilo) f(T) U (*eq. 2*)
+!
+! Once values of T, U, and q have been calculated for the inhomogeneous
+! path, this sets U_c for the corresponding
+! homogeneous atmosphere. However, this need not equal the
+! value of U_c' defined by eq. 1 for the actual inhomogeneous atmosphere
+! under consideration.
+!
+! Solution: hold T and q constant, solve for U' that gives U_c' by
+! inverting eq. (2):
+!
+! U' = (U_c * epsilo) / (q * f(T))
+!
+ fch2o = fh2oself(t_p)
+ uch2o = (pch2o * epsilo) / (q_path * fch2o)
+
+!
+! Band-dependent indices for non-window
+!
+ ib = 1
+
+ uvar = ub(ib) * fdif
+ log_u = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
+ dvar = (log_u - min_lu_h2o) / dlu_h2o
+ iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
+ iu1 = iu + 1
+ wu = dvar - floor(dvar)
+ wu1 = 1.0 - wu
+
+ log_p = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o)
+ dvar = (log_p - min_lp_h2o) / dlp_h2o
+ ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
+ ip1 = ip + 1
+ wp = dvar - floor(dvar)
+ wp1 = 1.0 - wp
+
+ w00_00 = wp * w_0_00
+ w00_01 = wp * w_0_01
+ w00_10 = wp * w_0_10
+ w00_11 = wp * w_0_11
+ w01_00 = wp * w_1_00
+ w01_01 = wp * w_1_01
+ w01_10 = wp * w_1_10
+ w01_11 = wp * w_1_11
+ w10_00 = wp1 * w_0_00
+ w10_01 = wp1 * w_0_01
+ w10_10 = wp1 * w_0_10
+ w10_11 = wp1 * w_0_11
+ w11_00 = wp1 * w_1_00
+ w11_01 = wp1 * w_1_01
+ w11_10 = wp1 * w_1_10
+ w11_11 = wp1 * w_1_11
+
+!
+! Asymptotic value of emissivity as U->infinity
+!
+ fe = fet(1,ib) + &
+ fet(2,ib) * te1 + &
+ fet(3,ib) * te2 + &
+ fet(4,ib) * te3 + &
+ fet(5,ib) * te4 + &
+ fet(6,ib) * te5
+
+ e_star = &
+ eh2onw(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
+ eh2onw(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
+ eh2onw(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
+ eh2onw(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
+ eh2onw(ip , itp , iu1, ite , irh ) * w11_11 * wu + &
+ eh2onw(ip , itp , iu1, ite , irh1) * w11_10 * wu + &
+ eh2onw(ip , itp , iu1, ite1, irh ) * w11_01 * wu + &
+ eh2onw(ip , itp , iu1, ite1, irh1) * w11_00 * wu + &
+ eh2onw(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
+ eh2onw(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
+ eh2onw(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
+ eh2onw(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
+ eh2onw(ip , itp1, iu1, ite , irh ) * w10_11 * wu + &
+ eh2onw(ip , itp1, iu1, ite , irh1) * w10_10 * wu + &
+ eh2onw(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + &
+ eh2onw(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + &
+ eh2onw(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
+ eh2onw(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
+ eh2onw(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
+ eh2onw(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
+ eh2onw(ip1, itp , iu1, ite , irh ) * w01_11 * wu + &
+ eh2onw(ip1, itp , iu1, ite , irh1) * w01_10 * wu + &
+ eh2onw(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + &
+ eh2onw(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + &
+ eh2onw(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
+ eh2onw(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
+ eh2onw(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
+ eh2onw(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
+ eh2onw(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + &
+ eh2onw(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + &
+ eh2onw(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + &
+ eh2onw(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
+ emis(i,ib) = min(max(fe * (1.0 - (1.0 - e_star) * &
+ aer_trn_ttl(i,k1,1,ib)), &
+ 0.0_r8), 1.0_r8)
+!
+! Invoke linear limit for scaling wrt u below min_u_h2o
+!
+ if (uvar < min_u_h2o) then
+ uscl = uvar / min_u_h2o
+ emis(i,ib) = emis(i,ib) * uscl
+ endif
+
+
+
+!
+! Band-dependent indices for window
+!
+ ib = 2
+
+ uvar = ub(ib) * fdif
+ log_u = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
+ dvar = (log_u - min_lu_h2o) / dlu_h2o
+ iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
+ iu1 = iu + 1
+ wu = dvar - floor(dvar)
+ wu1 = 1.0 - wu
+
+ log_p = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o)
+ dvar = (log_p - min_lp_h2o) / dlp_h2o
+ ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
+ ip1 = ip + 1
+ wp = dvar - floor(dvar)
+ wp1 = 1.0 - wp
+
+ w00_00 = wp * w_0_00
+ w00_01 = wp * w_0_01
+ w00_10 = wp * w_0_10
+ w00_11 = wp * w_0_11
+ w01_00 = wp * w_1_00
+ w01_01 = wp * w_1_01
+ w01_10 = wp * w_1_10
+ w01_11 = wp * w_1_11
+ w10_00 = wp1 * w_0_00
+ w10_01 = wp1 * w_0_01
+ w10_10 = wp1 * w_0_10
+ w10_11 = wp1 * w_0_11
+ w11_00 = wp1 * w_1_00
+ w11_01 = wp1 * w_1_01
+ w11_10 = wp1 * w_1_10
+ w11_11 = wp1 * w_1_11
+
+ log_uc = min(log10(max(uch2o * fdif, min_u_h2o)), max_lu_h2o)
+ dvar = (log_uc - min_lu_h2o) / dlu_h2o
+ iuc = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
+ iuc1 = iuc + 1
+ wuc = dvar - floor(dvar)
+ wuc1 = 1.0 - wuc
+!
+! Asymptotic value of emissivity as U->infinity
+!
+ fe = fet(1,ib) + &
+ fet(2,ib) * te1 + &
+ fet(3,ib) * te2 + &
+ fet(4,ib) * te3 + &
+ fet(5,ib) * te4 + &
+ fet(6,ib) * te5
+
+ l_star = &
+ ln_eh2ow(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
+ ln_eh2ow(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
+ ln_eh2ow(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
+ ln_eh2ow(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
+ ln_eh2ow(ip , itp , iu1, ite , irh ) * w11_11 * wu + &
+ ln_eh2ow(ip , itp , iu1, ite , irh1) * w11_10 * wu + &
+ ln_eh2ow(ip , itp , iu1, ite1, irh ) * w11_01 * wu + &
+ ln_eh2ow(ip , itp , iu1, ite1, irh1) * w11_00 * wu + &
+ ln_eh2ow(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
+ ln_eh2ow(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
+ ln_eh2ow(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
+ ln_eh2ow(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
+ ln_eh2ow(ip , itp1, iu1, ite , irh ) * w10_11 * wu + &
+ ln_eh2ow(ip , itp1, iu1, ite , irh1) * w10_10 * wu + &
+ ln_eh2ow(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + &
+ ln_eh2ow(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + &
+ ln_eh2ow(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
+ ln_eh2ow(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
+ ln_eh2ow(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
+ ln_eh2ow(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
+ ln_eh2ow(ip1, itp , iu1, ite , irh ) * w01_11 * wu + &
+ ln_eh2ow(ip1, itp , iu1, ite , irh1) * w01_10 * wu + &
+ ln_eh2ow(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + &
+ ln_eh2ow(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + &
+ ln_eh2ow(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
+ ln_eh2ow(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
+ ln_eh2ow(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
+ ln_eh2ow(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
+ ln_eh2ow(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + &
+ ln_eh2ow(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + &
+ ln_eh2ow(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + &
+ ln_eh2ow(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
+
+ c_star = &
+ cn_eh2ow(ip , itp , iuc , ite , irh ) * w11_11 * wuc1 + &
+ cn_eh2ow(ip , itp , iuc , ite , irh1) * w11_10 * wuc1 + &
+ cn_eh2ow(ip , itp , iuc , ite1, irh ) * w11_01 * wuc1 + &
+ cn_eh2ow(ip , itp , iuc , ite1, irh1) * w11_00 * wuc1 + &
+ cn_eh2ow(ip , itp , iuc1, ite , irh ) * w11_11 * wuc + &
+ cn_eh2ow(ip , itp , iuc1, ite , irh1) * w11_10 * wuc + &
+ cn_eh2ow(ip , itp , iuc1, ite1, irh ) * w11_01 * wuc + &
+ cn_eh2ow(ip , itp , iuc1, ite1, irh1) * w11_00 * wuc + &
+ cn_eh2ow(ip , itp1, iuc , ite , irh ) * w10_11 * wuc1 + &
+ cn_eh2ow(ip , itp1, iuc , ite , irh1) * w10_10 * wuc1 + &
+ cn_eh2ow(ip , itp1, iuc , ite1, irh ) * w10_01 * wuc1 + &
+ cn_eh2ow(ip , itp1, iuc , ite1, irh1) * w10_00 * wuc1 + &
+ cn_eh2ow(ip , itp1, iuc1, ite , irh ) * w10_11 * wuc + &
+ cn_eh2ow(ip , itp1, iuc1, ite , irh1) * w10_10 * wuc + &
+ cn_eh2ow(ip , itp1, iuc1, ite1, irh ) * w10_01 * wuc + &
+ cn_eh2ow(ip , itp1, iuc1, ite1, irh1) * w10_00 * wuc + &
+ cn_eh2ow(ip1, itp , iuc , ite , irh ) * w01_11 * wuc1 + &
+ cn_eh2ow(ip1, itp , iuc , ite , irh1) * w01_10 * wuc1 + &
+ cn_eh2ow(ip1, itp , iuc , ite1, irh ) * w01_01 * wuc1 + &
+ cn_eh2ow(ip1, itp , iuc , ite1, irh1) * w01_00 * wuc1 + &
+ cn_eh2ow(ip1, itp , iuc1, ite , irh ) * w01_11 * wuc + &
+ cn_eh2ow(ip1, itp , iuc1, ite , irh1) * w01_10 * wuc + &
+ cn_eh2ow(ip1, itp , iuc1, ite1, irh ) * w01_01 * wuc + &
+ cn_eh2ow(ip1, itp , iuc1, ite1, irh1) * w01_00 * wuc + &
+ cn_eh2ow(ip1, itp1, iuc , ite , irh ) * w00_11 * wuc1 + &
+ cn_eh2ow(ip1, itp1, iuc , ite , irh1) * w00_10 * wuc1 + &
+ cn_eh2ow(ip1, itp1, iuc , ite1, irh ) * w00_01 * wuc1 + &
+ cn_eh2ow(ip1, itp1, iuc , ite1, irh1) * w00_00 * wuc1 + &
+ cn_eh2ow(ip1, itp1, iuc1, ite , irh ) * w00_11 * wuc + &
+ cn_eh2ow(ip1, itp1, iuc1, ite , irh1) * w00_10 * wuc + &
+ cn_eh2ow(ip1, itp1, iuc1, ite1, irh ) * w00_01 * wuc + &
+ cn_eh2ow(ip1, itp1, iuc1, ite1, irh1) * w00_00 * wuc
+ emis(i,ib) = min(max(fe * (1.0 - l_star * c_star * &
+ aer_trn_ttl(i,k1,1,ib)), &
+ 0.0_r8), 1.0_r8)
+!
+! Invoke linear limit for scaling wrt u below min_u_h2o
+!
+ if (uvar < min_u_h2o) then
+ uscl = uvar / min_u_h2o
+ emis(i,ib) = emis(i,ib) * uscl
+ endif
+
+
+!
+! Compute total emissivity for H2O
+!
+ h2oems(i,k1) = emis(i,1)+emis(i,2)
+
+ end do
+!
+!
+!
+
+ do i=1,ncol
+ term7(i,1) = coefj(1,1) + coefj(2,1)*dty(i)*(1.+c16*dty(i))
+ term8(i,1) = coefk(1,1) + coefk(2,1)*dty(i)*(1.+c17*dty(i))
+ term7(i,2) = coefj(1,2) + coefj(2,2)*dty(i)*(1.+c26*dty(i))
+ term8(i,2) = coefk(1,2) + coefk(2,2)*dty(i)*(1.+c27*dty(i))
+ end do
+ do i=1,ncol
+!
+! 500 - 800 cm-1 rotation band overlap with co2
+!
+ k21(i) = term7(i,1) + term8(i,1)/ &
+ (1. + (c30 + c31*(dty(i)-10.)*(dty(i)-10.))*sqrt(u(i)))
+ k22(i) = term7(i,2) + term8(i,2)/ &
+ (1. + (c28 + c29*(dty(i)-10.))*sqrt(u(i)))
+ fwk = fwcoef + fwc1/(1.+fwc2*u(i))
+ tr1(i) = exp(-(k21(i)*(sqrt(u(i)) + fc1*fwk*u(i))))
+ tr2(i) = exp(-(k22(i)*(sqrt(u(i)) + fc1*fwk*u(i))))
+ tr1(i)=tr1(i)*aer_trn_ttl(i,k1,1,idx_LW_0650_0800)
+! ! H2O line+aer trn 650--800 cm-1
+ tr2(i)=tr2(i)*aer_trn_ttl(i,k1,1,idx_LW_0500_0650)
+! ! H2O line+aer trn 500--650 cm-1
+ tr3(i) = exp(-((coefh(1,1) + coefh(2,1)*dtx(i))*uc1(i)))
+ tr4(i) = exp(-((coefh(1,2) + coefh(2,2)*dtx(i))*uc1(i)))
+ tr7(i) = tr1(i)*tr3(i)
+ tr8(i) = tr2(i)*tr4(i)
+ troco2(i,k1) = 0.65*tr7(i) + 0.35*tr8(i)
+ th2o(i) = tr8(i)
+ end do
+!
+! CO2 emissivity for 15 micron band system
+!
+ do i=1,ncol
+ t1i = exp(-480./co2t(i,k1))
+ sqti = sqrt(co2t(i,k1))
+ rsqti = 1./sqti
+ et = t1i
+ et2 = et*et
+ et4 = et2*et2
+ omet = 1. - 1.5*et2
+ f1co2 = 899.70*omet*(1. + 1.94774*et + 4.73486*et2)*rsqti
+ sqwp = sqrt(plco2(i,k1))
+ f1sqwp = f1co2*sqwp
+ t1co2 = 1./(1. + 245.18*omet*sqwp*rsqti)
+ oneme = 1. - et2
+ alphat = oneme**3*rsqti
+ wco2 = 2.5221*co2vmr*pnm(i,k1)*rga
+ u7 = 4.9411e4*alphat*et2*wco2
+ u8 = 3.9744e4*alphat*et4*wco2
+ u9 = 1.0447e5*alphat*et4*et2*wco2
+ u13 = 2.8388e3*alphat*et4*wco2
+!
+ tpath = co2t(i,k1)
+ tlocal = tplnke(i)
+ tcrfac = sqrt((tlocal*r250)*(tpath*r300))
+ pi = pnm(i,k1)*rsslp + 2.*dpfco2*tcrfac
+ posqt = pi/(2.*sqti)
+ rbeta7 = 1./( 5.3288*posqt)
+ rbeta8 = 1./ (10.6576*posqt)
+ rbeta9 = rbeta7
+ rbeta13= rbeta9
+ f2co2 = (u7/sqrt(4. + u7*(1. + rbeta7))) + &
+ (u8/sqrt(4. + u8*(1. + rbeta8))) + &
+ (u9/sqrt(4. + u9*(1. + rbeta9)))
+ f3co2 = u13/sqrt(4. + u13*(1. + rbeta13))
+ tmp1 = log(1. + f1sqwp)
+ tmp2 = log(1. + f2co2)
+ tmp3 = log(1. + f3co2)
+ absbnd = (tmp1 + 2.*t1co2*tmp2 + 2.*tmp3)*sqti
+ tco2(i)=1.0/(1.0+10.0*(u7/sqrt(4. + u7*(1. + rbeta7))))
+ co2ems(i,k1) = troco2(i,k1)*absbnd*co2plk(i)
+ ex = exp(960./tint(i,k1))
+ exm1sq = (ex - 1.)**2
+ co2em(i,k1) = 1.2e11*ex/(tint(i,k1)*tint4(i,k1)*exm1sq)
+ end do
+!
+! O3 emissivity
+!
+ do i=1,ncol
+ h2otr(i,k1) = exp(-12.*s2c(i,k1))
+ h2otr(i,k1)=h2otr(i,k1)*aer_trn_ttl(i,k1,1,idx_LW_1000_1200)
+ te = (co2t(i,k1)/293.)**.7
+ u1 = 18.29*plos(i,k1)/te
+ u2 = .5649*plos(i,k1)/te
+ phat = plos(i,k1)/plol(i,k1)
+ tlocal = tplnke(i)
+ tcrfac = sqrt(tlocal*r250)*te
+ beta = (1./.3205)*((1./phat) + (dpfo3*tcrfac))
+ realnu = (1./beta)*te
+ o3bndi = 74.*te*(tplnke(i)/375.)*log(1. + fo3(u1,realnu) + fo3(u2,realnu))
+ o3ems(i,k1) = dbvtt(i)*h2otr(i,k1)*o3bndi
+ to3(i)=1.0/(1. + 0.1*fo3(u1,realnu) + 0.1*fo3(u2,realnu))
+ end do
+!
+! Calculate trace gas emissivities
+!
+ call trcems(lchnk ,ncol ,pcols, pverp, &
+ k1 ,co2t ,pnm ,ucfc11 ,ucfc12 , &
+ un2o0 ,un2o1 ,bn2o0 ,bn2o1 ,uch4 , &
+ bch4 ,uco211 ,uco212 ,uco213 ,uco221 , &
+ uco222 ,uco223 ,uptype ,w ,s2c , &
+ u ,emplnk ,th2o ,tco2 ,to3 , &
+ emstrc , &
+ aer_trn_ttl)
+!
+! Total emissivity:
+!
+ do i=1,ncol
+ emstot(i,k1) = h2oems(i,k1) + co2ems(i,k1) + o3ems(i,k1) &
+ + emstrc(i,k1)
+ end do
+ end do ! End of interface loop
+
+ return
+end subroutine radems
+
+subroutine radtpl(lchnk ,ncol ,pcols, pver, pverp, &
+ tnm ,lwupcgs ,qnm ,pnm ,plco2 ,plh2o , &
+ tplnka ,s2c ,tcg ,w ,tplnke , &
+ tint ,tint4 ,tlayr ,tlayr4 ,pmln , &
+ piln ,plh2ob ,wb )
+!--------------------------------------------------------------------
+!
+! Purpose:
+! Compute temperatures and path lengths for longwave radiation
+!
+! Method:
+! <Describe the algorithm(s) used in the routine.>
+! <Also include any applicable external references.>
+!
+! Author: CCM1
+!
+!--------------------------------------------------------------------
+
+!------------------------------Arguments-----------------------------
+!
+! Input arguments
+!
+ integer, intent(in) :: lchnk ! chunk identifier
+ integer, intent(in) :: ncol ! number of atmospheric columns
+ integer, intent(in) :: pcols, pver, pverp
+
+ real(r8), intent(in) :: tnm(pcols,pver) ! Model level temperatures
+ real(r8), intent(in) :: lwupcgs(pcols) ! Surface longwave up flux
+ real(r8), intent(in) :: qnm(pcols,pver) ! Model level specific humidity
+ real(r8), intent(in) :: pnm(pcols,pverp) ! Pressure at model interfaces (dynes/cm2)
+ real(r8), intent(in) :: pmln(pcols,pver) ! Ln(pmidm1)
+ real(r8), intent(in) :: piln(pcols,pverp) ! Ln(pintm1)
+!
+! Output arguments
+!
+ real(r8), intent(out) :: plco2(pcols,pverp) ! Pressure weighted co2 path
+ real(r8), intent(out) :: plh2o(pcols,pverp) ! Pressure weighted h2o path
+ real(r8), intent(out) :: tplnka(pcols,pverp) ! Level temperature from interface temperatures
+ real(r8), intent(out) :: s2c(pcols,pverp) ! H2o continuum path length
+ real(r8), intent(out) :: tcg(pcols,pverp) ! H2o-mass-wgted temp. (Curtis-Godson approx.)
+ real(r8), intent(out) :: w(pcols,pverp) ! H2o path length
+ real(r8), intent(out) :: tplnke(pcols) ! Equal to tplnka
+ real(r8), intent(out) :: tint(pcols,pverp) ! Layer interface temperature
+ real(r8), intent(out) :: tint4(pcols,pverp) ! Tint to the 4th power
+ real(r8), intent(out) :: tlayr(pcols,pverp) ! K-1 level temperature
+ real(r8), intent(out) :: tlayr4(pcols,pverp) ! Tlayr to the 4th power
+ real(r8), intent(out) :: plh2ob(nbands,pcols,pverp)! Pressure weighted h2o path with
+ ! Hulst-Curtis-Godson temp. factor
+ ! for H2O bands
+ real(r8), intent(out) :: wb(nbands,pcols,pverp) ! H2o path length with
+ ! Hulst-Curtis-Godson temp. factor
+ ! for H2O bands
+
+!
+!---------------------------Local variables--------------------------
+!
+ integer i ! Longitude index
+ integer k ! Level index
+ integer kp1 ! Level index + 1
+
+ real(r8) repsil ! Inver ratio mol weight h2o to dry air
+ real(r8) dy ! Thickness of layer for tmp interp
+ real(r8) dpnm ! Pressure thickness of layer
+ real(r8) dpnmsq ! Prs squared difference across layer
+ real(r8) dw ! Increment in H2O path length
+ real(r8) dplh2o ! Increment in plh2o
+ real(r8) cpwpl ! Const in co2 mix ratio to path length conversn
+
+!--------------------------------------------------------------------
+!
+ repsil = 1./epsilo
+!
+! Compute co2 and h2o paths
+!
+ cpwpl = amco2/amd * 0.5/(gravit*p0)
+ do i=1,ncol
+ plh2o(i,ntoplw) = rgsslp*qnm(i,ntoplw)*pnm(i,ntoplw)*pnm(i,ntoplw)
+ plco2(i,ntoplw) = co2vmr*cpwpl*pnm(i,ntoplw)*pnm(i,ntoplw)
+ end do
+ do k=ntoplw,pver
+ do i=1,ncol
+ plh2o(i,k+1) = plh2o(i,k) + rgsslp* &
+ (pnm(i,k+1)**2 - pnm(i,k)**2)*qnm(i,k)
+ plco2(i,k+1) = co2vmr*cpwpl*pnm(i,k+1)**2
+ end do
+ end do
+!
+! Set the top and bottom intermediate level temperatures,
+! top level planck temperature and top layer temp**4.
+!
+! Tint is lower interface temperature
+! (not available for bottom layer, so use ground temperature)
+!
+ do i=1,ncol
+ tint4(i,pverp) = lwupcgs(i)/stebol
+ tint(i,pverp) = sqrt(sqrt(tint4(i,pverp)))
+ tplnka(i,ntoplw) = tnm(i,ntoplw)
+ tint(i,ntoplw) = tplnka(i,ntoplw)
+ tlayr4(i,ntoplw) = tplnka(i,ntoplw)**4
+ tint4(i,ntoplw) = tlayr4(i,ntoplw)
+ end do
+!
+! Intermediate level temperatures are computed using temperature
+! at the full level below less dy*delta t,between the full level
+!
+ do k=ntoplw+1,pver
+ do i=1,ncol
+ dy = (piln(i,k) - pmln(i,k))/(pmln(i,k-1) - pmln(i,k))
+ tint(i,k) = tnm(i,k) - dy*(tnm(i,k)-tnm(i,k-1))
+ tint4(i,k) = tint(i,k)**4
+ end do
+ end do
+!
+! Now set the layer temp=full level temperatures and establish a
+! planck temperature for absorption (tplnka) which is the average
+! the intermediate level temperatures. Note that tplnka is not
+! equal to the full level temperatures.
+!
+ do k=ntoplw+1,pverp
+ do i=1,ncol
+ tlayr(i,k) = tnm(i,k-1)
+ tlayr4(i,k) = tlayr(i,k)**4
+ tplnka(i,k) = .5*(tint(i,k) + tint(i,k-1))
+ end do
+ end do
+!
+! Calculate tplank for emissivity calculation.
+! Assume isothermal tplnke i.e. all levels=ttop.
+!
+ do i=1,ncol
+ tplnke(i) = tplnka(i,ntoplw)
+ tlayr(i,ntoplw) = tint(i,ntoplw)
+ end do
+!
+! Now compute h2o path fields:
+!
+ do i=1,ncol
+!
+! Changed effective path temperature to std. Curtis-Godson form
+!
+ tcg(i,ntoplw) = rga*qnm(i,ntoplw)*pnm(i,ntoplw)*tnm(i,ntoplw)
+ w(i,ntoplw) = sslp * (plh2o(i,ntoplw)*2.) / pnm(i,ntoplw)
+!
+! Hulst-Curtis-Godson scaling for H2O path
+!
+ wb(1,i,ntoplw) = w(i,ntoplw) * phi(tnm(i,ntoplw),1)
+ wb(2,i,ntoplw) = w(i,ntoplw) * phi(tnm(i,ntoplw),2)
+!
+! Hulst-Curtis-Godson scaling for effective pressure along H2O path
+!
+ plh2ob(1,i,ntoplw) = plh2o(i,ntoplw) * psi(tnm(i,ntoplw),1)
+ plh2ob(2,i,ntoplw) = plh2o(i,ntoplw) * psi(tnm(i,ntoplw),2)
+
+ s2c(i,ntoplw) = plh2o(i,ntoplw)*fh2oself(tnm(i,ntoplw))*qnm(i,ntoplw)*repsil
+ end do
+
+ do k=ntoplw,pver
+ do i=1,ncol
+ dpnm = pnm(i,k+1) - pnm(i,k)
+ dpnmsq = pnm(i,k+1)**2 - pnm(i,k)**2
+ dw = rga*qnm(i,k)*dpnm
+ kp1 = k+1
+ w(i,kp1) = w(i,k) + dw
+!
+! Hulst-Curtis-Godson scaling for H2O path
+!
+ wb(1,i,kp1) = wb(1,i,k) + dw * phi(tnm(i,k),1)
+ wb(2,i,kp1) = wb(2,i,k) + dw * phi(tnm(i,k),2)
+!
+! Hulst-Curtis-Godson scaling for effective pressure along H2O path
+!
+ dplh2o = plh2o(i,kp1) - plh2o(i,k)
+
+ plh2ob(1,i,kp1) = plh2ob(1,i,k) + dplh2o * psi(tnm(i,k),1)
+ plh2ob(2,i,kp1) = plh2ob(2,i,k) + dplh2o * psi(tnm(i,k),2)
+!
+! Changed effective path temperature to std. Curtis-Godson form
+!
+ tcg(i,kp1) = tcg(i,k) + dw*tnm(i,k)
+ s2c(i,kp1) = s2c(i,k) + rgsslp*dpnmsq*qnm(i,k)* &
+ fh2oself(tnm(i,k))*qnm(i,k)*repsil
+ end do
+ end do
+!
+ return
+end subroutine radtpl
+
+
+subroutine radclwmx(lchnk ,ncol ,pcols, pver, pverp, &
+ lwupcgs ,tnm ,qnm ,o3vmr , &
+ pmid ,pint ,pmln ,piln , &
+ n2o ,ch4 ,cfc11 ,cfc12 , &
+ cld ,emis ,pmxrgn ,nmxrgn ,qrl , &
+ doabsems, abstot, absnxt, emstot, &
+ flns ,flnt ,flnsc ,flntc ,flwds , &
+ flut ,flutc , &
+ flup ,flupc ,fldn ,fldnc , &
+ aer_mass)
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Compute longwave radiation heating rates and boundary fluxes
+!
+! Method:
+! Uses broad band absorptivity/emissivity method to compute clear sky;
+! assumes randomly overlapped clouds with variable cloud emissivity to
+! include effects of clouds.
+!
+! Computes clear sky absorptivity/emissivity at lower frequency (in
+! general) than the model radiation frequency; uses previously computed
+! and stored values for efficiency
+!
+! Note: This subroutine contains vertical indexing which proceeds
+! from bottom to top rather than the top to bottom indexing
+! used in the rest of the model.
+!
+! Author: B. Collins
+!
+!-----------------------------------------------------------------------
+! use shr_kind_mod, only: r8 => shr_kind_r8
+! use ppgrid
+! use radae, only: nbands, radems, radabs, radtpl, abstot_3d, absnxt_3d, emstot_3d
+! use volcrad
+
+ implicit none
+
+ integer pverp2,pverp3,pverp4
+! parameter (pverp2=pver+2,pverp3=pver+3,pverp4=pver+4)
+
+ real(r8) cldmin
+ parameter (cldmin = 1.0d-80)
+!------------------------------Commons----------------------------------
+!-----------------------------------------------------------------------
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+ integer, intent(in) :: lchnk ! chunk identifier
+ integer, intent(in) :: pcols, pver, pverp
+ integer, intent(in) :: ncol ! number of atmospheric columns
+! maximally overlapped region.
+! 0->pmxrgn(i,1) is range of pmid for
+! 1st region, pmxrgn(i,1)->pmxrgn(i,2) for
+! 2nd region, etc
+ integer, intent(in) :: nmxrgn(pcols) ! Number of maximally overlapped regions
+ logical, intent(in) :: doabsems
+
+ real(r8), intent(in) :: pmxrgn(pcols,pverp) ! Maximum values of pmid for each
+ real(r8), intent(in) :: lwupcgs(pcols) ! Longwave up flux in CGS units
+!
+! Input arguments which are only passed to other routines
+!
+ real(r8), intent(in) :: tnm(pcols,pver) ! Level temperature
+ real(r8), intent(in) :: qnm(pcols,pver) ! Level moisture field
+ real(r8), intent(in) :: o3vmr(pcols,pver) ! ozone volume mixing ratio
+ real(r8), intent(in) :: pmid(pcols,pver) ! Level pressure
+ real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressure
+ real(r8), intent(in) :: pmln(pcols,pver) ! Ln(pmid)
+ real(r8), intent(in) :: piln(pcols,pverp) ! Ln(pint)
+ real(r8), intent(in) :: n2o(pcols,pver) ! nitrous oxide mass mixing ratio
+ real(r8), intent(in) :: ch4(pcols,pver) ! methane mass mixing ratio
+ real(r8), intent(in) :: cfc11(pcols,pver) ! cfc11 mass mixing ratio
+ real(r8), intent(in) :: cfc12(pcols,pver) ! cfc12 mass mixing ratio
+ real(r8), intent(in) :: cld(pcols,pver) ! Cloud cover
+ real(r8), intent(in) :: emis(pcols,pver) ! Cloud emissivity
+ real(r8), intent(in) :: aer_mass(pcols,pver) ! STRAER mass in layer
+
+!
+! Output arguments
+!
+ real(r8), intent(out) :: qrl(pcols,pver) ! Longwave heating rate
+ real(r8), intent(out) :: flns(pcols) ! Surface cooling flux
+ real(r8), intent(out) :: flnt(pcols) ! Net outgoing flux
+ real(r8), intent(out) :: flut(pcols) ! Upward flux at top of model
+ real(r8), intent(out) :: flnsc(pcols) ! Clear sky surface cooing
+ real(r8), intent(out) :: flntc(pcols) ! Net clear sky outgoing flux
+ real(r8), intent(out) :: flutc(pcols) ! Upward clear-sky flux at top of model
+ real(r8), intent(out) :: flwds(pcols) ! Down longwave flux at surface
+! Added downward/upward total and clear sky fluxes
+ real(r8), intent(out) :: flup(pcols,pverp) ! Total sky upward longwave flux
+ real(r8), intent(out) :: flupc(pcols,pverp) ! Clear sky upward longwave flux
+ real(r8), intent(out) :: fldn(pcols,pverp) ! Total sky downward longwave flux
+ real(r8), intent(out) :: fldnc(pcols,pverp) ! Clear sky downward longwave flux
+!
+ real(r8), intent(inout) :: abstot(pcols,pverp,pverp) ! Total absorptivity
+ real(r8), intent(inout) :: absnxt(pcols,pver,4) ! Total nearest layer absorptivity
+ real(r8), intent(inout) :: emstot(pcols,pverp) ! Total emissivity
+
+!---------------------------Local variables-----------------------------
+!
+ integer i ! Longitude index
+ integer ilon ! Longitude index
+ integer ii ! Longitude index
+ integer iimx ! Longitude index (max overlap)
+ integer k ! Level index
+ integer k1 ! Level index
+ integer k2 ! Level index
+ integer k3 ! Level index
+ integer km ! Level index
+ integer km1 ! Level index
+ integer km3 ! Level index
+ integer km4 ! Level index
+ integer irgn ! Index for max-overlap regions
+ integer l ! Index for clouds to overlap
+ integer l1 ! Index for clouds to overlap
+ integer n ! Counter
+
+!
+ real(r8) :: plco2(pcols,pverp) ! Path length co2
+ real(r8) :: plh2o(pcols,pverp) ! Path length h2o
+ real(r8) tmp(pcols) ! Temporary workspace
+ real(r8) tmp2(pcols) ! Temporary workspace
+ real(r8) absbt(pcols) ! Downward emission at model top
+ real(r8) plol(pcols,pverp) ! O3 pressure wghted path length
+ real(r8) plos(pcols,pverp) ! O3 path length
+ real(r8) aer_mpp(pcols,pverp) ! STRAER path above kth interface level
+ real(r8) co2em(pcols,pverp) ! Layer co2 normalized planck funct. derivative
+ real(r8) co2eml(pcols,pver) ! Interface co2 normalized planck funct. deriv.
+ real(r8) delt(pcols) ! Diff t**4 mid layer to top interface
+ real(r8) delt1(pcols) ! Diff t**4 lower intrfc to mid layer
+ real(r8) bk1(pcols) ! Absrptvty for vertical quadrature
+ real(r8) bk2(pcols) ! Absrptvty for vertical quadrature
+ real(r8) cldp(pcols,pverp) ! Cloud cover with extra layer
+ real(r8) ful(pcols,pverp) ! Total upwards longwave flux
+ real(r8) fsul(pcols,pverp) ! Clear sky upwards longwave flux
+ real(r8) fdl(pcols,pverp) ! Total downwards longwave flux
+ real(r8) fsdl(pcols,pverp) ! Clear sky downwards longwv flux
+ real(r8) fclb4(pcols,-1:pver) ! Sig t**4 for cld bottom interfc
+ real(r8) fclt4(pcols,0:pver) ! Sig t**4 for cloud top interfc
+ real(r8) s(pcols,pverp,pverp) ! Flx integral sum
+ real(r8) tplnka(pcols,pverp) ! Planck fnctn temperature
+ real(r8) s2c(pcols,pverp) ! H2o cont amount
+ real(r8) tcg(pcols,pverp) ! H2o-mass-wgted temp. (Curtis-Godson approx.)
+ real(r8) w(pcols,pverp) ! H2o path
+ real(r8) tplnke(pcols) ! Planck fnctn temperature
+ real(r8) h2otr(pcols,pverp) ! H2o trnmsn for o3 overlap
+ real(r8) co2t(pcols,pverp) ! Prs wghted temperature path
+ real(r8) tint(pcols,pverp) ! Interface temperature
+ real(r8) tint4(pcols,pverp) ! Interface temperature**4
+ real(r8) tlayr(pcols,pverp) ! Level temperature
+ real(r8) tlayr4(pcols,pverp) ! Level temperature**4
+ real(r8) plh2ob(nbands,pcols,pverp)! Pressure weighted h2o path with
+ ! Hulst-Curtis-Godson temp. factor
+ ! for H2O bands
+ real(r8) wb(nbands,pcols,pverp) ! H2o path length with
+ ! Hulst-Curtis-Godson temp. factor
+ ! for H2O bands
+
+ real(r8) cld0 ! previous cloud amt (for max overlap)
+ real(r8) cld1 ! next cloud amt (for max overlap)
+ real(r8) emx(0:pverp) ! Emissivity factors (max overlap)
+ real(r8) emx0 ! Emissivity factors for BCs (max overlap)
+ real(r8) trans ! 1 - emis
+ real(r8) asort(pver) ! 1 - cloud amounts to be sorted for max ovrlp.
+ real(r8) atmp ! Temporary storage for sort when nxs = 2
+ real(r8) maxcld(pcols) ! Maximum cloud at any layer
+
+ integer indx(pcols) ! index vector of gathered array values
+!!$ integer indxmx(pcols+1,pverp)! index vector of gathered array values
+ integer indxmx(pcols,pverp)! index vector of gathered array values
+! (max overlap)
+ integer nrgn(pcols) ! Number of max overlap regions at longitude
+ integer npts ! number of values satisfying some criterion
+ integer ncolmx(pverp) ! number of columns with clds in region
+ integer kx1(pcols,pverp) ! Level index for top of max-overlap region
+ integer kx2(pcols,0:pverp)! Level index for bottom of max-overlap region
+ integer kxs(0:pverp,pcols,pverp)! Level indices for cld layers sorted by cld()
+! in descending order
+ integer nxs(pcols,pverp) ! Number of cloudy layers between kx1 and kx2
+ integer nxsk ! Number of cloudy layers between (kx1/kx2)&k
+ integer ksort(0:pverp) ! Level indices of cloud amounts to be sorted
+! for max ovrlp. calculation
+ integer ktmp ! Temporary storage for sort when nxs = 2
+
+! real aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! [fraction] Total
+ real(r8) aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! [fraction] Total
+! ! transmission between interfaces k1 and k2
+!
+! Pointer variables to 3d structures
+!
+! real(r8), pointer :: abstot(:,:,:)
+! real(r8), pointer :: absnxt(:,:,:)
+! real(r8), pointer :: emstot(:,:)
+
+!
+! Trace gas variables
+!
+ real(r8) ucfc11(pcols,pverp) ! CFC11 path length
+ real(r8) ucfc12(pcols,pverp) ! CFC12 path length
+ real(r8) un2o0(pcols,pverp) ! N2O path length
+ real(r8) un2o1(pcols,pverp) ! N2O path length (hot band)
+ real(r8) uch4(pcols,pverp) ! CH4 path length
+ real(r8) uco211(pcols,pverp) ! CO2 9.4 micron band path length
+ real(r8) uco212(pcols,pverp) ! CO2 9.4 micron band path length
+ real(r8) uco213(pcols,pverp) ! CO2 9.4 micron band path length
+ real(r8) uco221(pcols,pverp) ! CO2 10.4 micron band path length
+ real(r8) uco222(pcols,pverp) ! CO2 10.4 micron band path length
+ real(r8) uco223(pcols,pverp) ! CO2 10.4 micron band path length
+ real(r8) bn2o0(pcols,pverp) ! pressure factor for n2o
+ real(r8) bn2o1(pcols,pverp) ! pressure factor for n2o
+ real(r8) bch4(pcols,pverp) ! pressure factor for ch4
+ real(r8) uptype(pcols,pverp) ! p-type continuum path length
+ real(r8) abplnk1(14,pcols,pverp) ! non-nearest layer Plack factor
+ real(r8) abplnk2(14,pcols,pverp) ! nearest layer factor
+!
+!
+!-----------------------------------------------------------------------
+!
+!
+ pverp2=pver+2
+ pverp3=pver+3
+ pverp4=pver+4
+!
+! Set pointer variables
+!
+! abstot => abstot_3d(:,:,:,lchnk)
+! absnxt => absnxt_3d(:,:,:,lchnk)
+! emstot => emstot_3d(:,:,lchnk)
+!
+! accumulate mass path from top of atmosphere
+!
+ call aer_pth(aer_mass, aer_mpp, ncol, pcols, pver, pverp)
+
+!
+! Calculate some temperatures needed to derive absorptivity and
+! emissivity, as well as some h2o path lengths
+!
+ call radtpl(lchnk ,ncol ,pcols, pver, pverp, &
+ tnm ,lwupcgs ,qnm ,pint ,plco2 ,plh2o , &
+ tplnka ,s2c ,tcg ,w ,tplnke , &
+ tint ,tint4 ,tlayr ,tlayr4 ,pmln , &
+ piln ,plh2ob ,wb )
+ if (doabsems) then
+!
+! Compute ozone path lengths at frequency of a/e calculation.
+!
+ call radoz2(lchnk, ncol, pcols, pver, pverp, o3vmr ,pint ,plol ,plos, ntoplw )
+!
+! Compute trace gas path lengths
+!
+ call trcpth(lchnk ,ncol ,pcols, pver, pverp, &
+ tnm ,pint ,cfc11 ,cfc12 ,n2o , &
+ ch4 ,qnm ,ucfc11 ,ucfc12 ,un2o0 , &
+ un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , &
+ uco221 ,uco222 ,uco223 ,bn2o0 ,bn2o1 , &
+ bch4 ,uptype )
+
+! Compute transmission through STRAER absorption continuum
+ call aer_trn(aer_mpp, aer_trn_ttl, pcols, pver, pverp)
+
+!
+!
+! Compute total emissivity:
+!
+ call radems(lchnk ,ncol ,pcols, pver, pverp, &
+ s2c ,tcg ,w ,tplnke ,plh2o , &
+ pint ,plco2 ,tint ,tint4 ,tlayr , &
+ tlayr4 ,plol ,plos ,ucfc11 ,ucfc12 , &
+ un2o0 ,un2o1 ,uch4 ,uco211 ,uco212 , &
+ uco213 ,uco221 ,uco222 ,uco223 ,uptype , &
+ bn2o0 ,bn2o1 ,bch4 ,co2em ,co2eml , &
+ co2t ,h2otr ,abplnk1 ,abplnk2 ,emstot , &
+ plh2ob ,wb , &
+ aer_trn_ttl)
+!
+! Compute total absorptivity:
+!
+ call radabs(lchnk ,ncol ,pcols, pver, pverp, &
+ pmid ,pint ,co2em ,co2eml ,tplnka , &
+ s2c ,tcg ,w ,h2otr ,plco2 , &
+ plh2o ,co2t ,tint ,tlayr ,plol , &
+ plos ,pmln ,piln ,ucfc11 ,ucfc12 , &
+ un2o0 ,un2o1 ,uch4 ,uco211 ,uco212 , &
+ uco213 ,uco221 ,uco222 ,uco223 ,uptype , &
+ bn2o0 ,bn2o1 ,bch4 ,abplnk1 ,abplnk2 , &
+ abstot ,absnxt ,plh2ob ,wb , &
+ aer_mpp ,aer_trn_ttl)
+ end if
+!
+! Compute sums used in integrals (all longitude points)
+!
+! Definition of bk1 & bk2 depends on finite differencing. for
+! trapezoidal rule bk1=bk2. trapezoidal rule applied for nonadjacent
+! layers only.
+!
+! delt=t**4 in layer above current sigma level km.
+! delt1=t**4 in layer below current sigma level km.
+!
+ do i=1,ncol
+ delt(i) = tint4(i,pver) - tlayr4(i,pverp)
+ delt1(i) = tlayr4(i,pverp) - tint4(i,pverp)
+ s(i,pverp,pverp) = stebol*(delt1(i)*absnxt(i,pver,1) + delt (i)*absnxt(i,pver,4))
+ s(i,pver,pverp) = stebol*(delt (i)*absnxt(i,pver,2) + delt1(i)*absnxt(i,pver,3))
+ end do
+ do k=ntoplw,pver-1
+ do i=1,ncol
+ bk2(i) = (abstot(i,k,pver) + abstot(i,k,pverp))*0.5
+ bk1(i) = bk2(i)
+ s(i,k,pverp) = stebol*(bk2(i)*delt(i) + bk1(i)*delt1(i))
+ end do
+ end do
+!
+! All k, km>1
+!
+ do km=pver,ntoplw+1,-1
+ do i=1,ncol
+ delt(i) = tint4(i,km-1) - tlayr4(i,km)
+ delt1(i) = tlayr4(i,km) - tint4(i,km)
+ end do
+ do k=pverp,ntoplw,-1
+ if (k == km) then
+ do i=1,ncol
+ bk2(i) = absnxt(i,km-1,4)
+ bk1(i) = absnxt(i,km-1,1)
+ end do
+ else if (k == km-1) then
+ do i=1,ncol
+ bk2(i) = absnxt(i,km-1,2)
+ bk1(i) = absnxt(i,km-1,3)
+ end do
+ else
+ do i=1,ncol
+ bk2(i) = (abstot(i,k,km-1) + abstot(i,k,km))*0.5
+ bk1(i) = bk2(i)
+ end do
+ end if
+ do i=1,ncol
+ s(i,k,km) = s(i,k,km+1) + stebol*(bk2(i)*delt(i) + bk1(i)*delt1(i))
+ end do
+ end do
+ end do
+!
+! Computation of clear sky fluxes always set first level of fsul
+!
+ do i=1,ncol
+ fsul(i,pverp) = lwupcgs(i)
+ end do
+!
+! Downward clear sky fluxes store intermediate quantities in down flux
+! Initialize fluxes to clear sky values.
+!
+ do i=1,ncol
+ tmp(i) = fsul(i,pverp) - stebol*tint4(i,pverp)
+ fsul(i,ntoplw) = fsul(i,pverp) - abstot(i,ntoplw,pverp)*tmp(i) + s(i,ntoplw,ntoplw+1)
+ fsdl(i,ntoplw) = stebol*(tplnke(i)**4)*emstot(i,ntoplw)
+ end do
+!
+! fsdl(i,pverp) assumes isothermal layer
+!
+ do k=ntoplw+1,pver
+ do i=1,ncol
+ fsul(i,k) = fsul(i,pverp) - abstot(i,k,pverp)*tmp(i) + s(i,k,k+1)
+ fsdl(i,k) = stebol*(tplnke(i)**4)*emstot(i,k) - (s(i,k,ntoplw+1) - s(i,k,k+1))
+ end do
+ end do
+!
+! Store the downward emission from level 1 = total gas emission * sigma
+! t**4. fsdl does not yet include all terms
+!
+ do i=1,ncol
+ absbt(i) = stebol*(tplnke(i)**4)*emstot(i,pverp)
+ fsdl(i,pverp) = absbt(i) - s(i,pverp,ntoplw+1)
+ end do
+!
+!----------------------------------------------------------------------
+! Modifications for clouds -- max/random overlap assumption
+!
+! The column is divided into sets of adjacent layers, called regions,
+! in which the clouds are maximally overlapped. The clouds are
+! randomly overlapped between different regions. The number of
+! regions in a column is set by nmxrgn, and the range of pressures
+! included in each region is set by pmxrgn. The max/random overlap
+! can be written in terms of the solutions of random overlap with
+! cloud amounts = 1. The random overlap assumption is equivalent to
+! setting the flux boundary conditions (BCs) at the edges of each region
+! equal to the mean all-sky flux at those boundaries. Since the
+! emissivity array for propogating BCs is only computed for the
+! TOA BC, the flux BCs elsewhere in the atmosphere have to be formulated
+! in terms of solutions to the random overlap equations. This is done
+! by writing the flux BCs as the sum of a clear-sky flux and emission
+! from a cloud outside the region weighted by an emissivity. This
+! emissivity is determined from the location of the cloud and the
+! flux BC.
+!
+! Copy cloud amounts to buffer with extra layer (needed for overlap logic)
+!
+ cldp(:ncol,ntoplw:pver) = cld(:ncol,ntoplw:pver)
+ cldp(:ncol,pverp) = 0.0
+!
+!
+! Select only those locations where there are no clouds
+! (maximum cloud fraction <= 1.e-3 treated as clear)
+! Set all-sky fluxes to clear-sky values.
+!
+ maxcld(1:ncol) = maxval(cldp(1:ncol,ntoplw:pver),dim=2)
+
+ npts = 0
+ do i=1,ncol
+ if (maxcld(i) < cldmin) then
+ npts = npts + 1
+ indx(npts) = i
+ end if
+ end do
+
+ do ii = 1, npts
+ i = indx(ii)
+ do k = ntoplw, pverp
+ fdl(i,k) = fsdl(i,k)
+ ful(i,k) = fsul(i,k)
+ end do
+ end do
+!
+! Select only those locations where there are clouds
+!
+ npts = 0
+ do i=1,ncol
+ if (maxcld(i) >= cldmin) then
+ npts = npts + 1
+ indx(npts) = i
+ end if
+ end do
+
+!
+! Initialize all-sky fluxes. fdl(i,1) & ful(i,pverp) are boundary conditions
+!
+ do ii = 1, npts
+ i = indx(ii)
+ fdl(i,ntoplw) = fsdl(i,ntoplw)
+ fdl(i,pverp) = 0.0
+ ful(i,ntoplw) = 0.0
+ ful(i,pverp) = fsul(i,pverp)
+ do k = ntoplw+1, pver
+ fdl(i,k) = 0.0
+ ful(i,k) = 0.0
+ end do
+!
+! Initialize Planck emission from layer boundaries
+!
+ do k = ntoplw, pver
+ fclt4(i,k-1) = stebol*tint4(i,k)
+ fclb4(i,k-1) = stebol*tint4(i,k+1)
+ enddo
+ fclb4(i,ntoplw-2) = stebol*tint4(i,ntoplw)
+ fclt4(i,pver) = stebol*tint4(i,pverp)
+!
+! Initialize indices for layers to be max-overlapped
+!
+ do irgn = 0, nmxrgn(i)
+ kx2(i,irgn) = ntoplw-1
+ end do
+ nrgn(i) = 0
+ end do
+
+!----------------------------------------------------------------------
+! INDEX CALCULATIONS FOR MAX OVERLAP
+
+ do ii = 1, npts
+ ilon = indx(ii)
+
+!
+! Outermost loop over regions (sets of adjacent layers) to be max overlapped
+!
+ do irgn = 1, nmxrgn(ilon)
+!
+! Calculate min/max layer indices inside region.
+!
+ n = 0
+ if (kx2(ilon,irgn-1) < pver) then
+ nrgn(ilon) = irgn
+ k1 = kx2(ilon,irgn-1)+1
+ kx1(ilon,irgn) = k1
+ kx2(ilon,irgn) = 0
+ do k2 = pver, k1, -1
+ if (pmid(ilon,k2) <= pmxrgn(ilon,irgn)) then
+ kx2(ilon,irgn) = k2
+ exit
+ end if
+ end do
+!
+! Identify columns with clouds in the given region.
+!
+ do k = k1, k2
+ if (cldp(ilon,k) >= cldmin) then
+ n = n+1
+ indxmx(n,irgn) = ilon
+ exit
+ endif
+ end do
+ endif
+ ncolmx(irgn) = n
+!
+! Dummy value for handling clear-sky regions
+!
+!!$ indxmx(ncolmx(irgn)+1,irgn) = ncol+1
+!
+! Outer loop over columns with clouds in the max-overlap region
+!
+ do iimx = 1, ncolmx(irgn)
+ i = indxmx(iimx,irgn)
+!
+! Sort cloud areas and corresponding level indices.
+!
+ n = 0
+ do k = kx1(i,irgn),kx2(i,irgn)
+ if (cldp(i,k) >= cldmin) then
+ n = n+1
+ ksort(n) = k
+!
+! We need indices for clouds in order of largest to smallest, so
+! sort 1-cld in ascending order
+!
+ asort(n) = 1.0-cldp(i,k)
+ end if
+ end do
+ nxs(i,irgn) = n
+!
+! If nxs(i,irgn) eq 1, no need to sort.
+! If nxs(i,irgn) eq 2, sort by swapping if necessary
+! If nxs(i,irgn) ge 3, sort using local sort routine
+!
+ if (nxs(i,irgn) == 2) then
+ if (asort(2) < asort(1)) then
+ ktmp = ksort(1)
+ ksort(1) = ksort(2)
+ ksort(2) = ktmp
+
+ atmp = asort(1)
+ asort(1) = asort(2)
+ asort(2) = atmp
+ endif
+ else if (nxs(i,irgn) >= 3) then
+ call sortarray(nxs(i,irgn),asort,ksort(1:))
+ endif
+
+ do l = 1, nxs(i,irgn)
+ kxs(l,i,irgn) = ksort(l)
+ end do
+!
+! End loop over longitude i for fluxes
+!
+ end do
+!
+! End loop over regions irgn for max-overlap
+!
+ end do
+!
+!----------------------------------------------------------------------
+! DOWNWARD FLUXES:
+! Outermost loop over regions (sets of adjacent layers) to be max overlapped
+!
+ do irgn = 1, nmxrgn(ilon)
+!
+! Compute clear-sky fluxes for regions without clouds
+!
+ iimx = 1
+ if (ilon < indxmx(iimx,irgn) .and. irgn <= nrgn(ilon)) then
+!
+! Calculate emissivity so that downward flux at upper boundary of region
+! can be cast in form of solution for downward flux from cloud above
+! that boundary. Then solutions for fluxes at other levels take form of
+! random overlap expressions. Try to locate "cloud" as close as possible
+! to TOA such that the "cloud" pseudo-emissivity is between 0 and 1.
+!
+ k1 = kx1(ilon,irgn)
+ do km1 = ntoplw-2, k1-2
+ km4 = km1+3
+ k2 = k1
+ k3 = k2+1
+ tmp(ilon) = s(ilon,k2,min(k3,pverp))*min(1,pverp2-k3)
+ emx0 = (fdl(ilon,k1)-fsdl(ilon,k1))/ &
+ ((fclb4(ilon,km1)-s(ilon,k2,km4)+tmp(ilon))- fsdl(ilon,k1))
+ if (emx0 >= 0.0 .and. emx0 <= 1.0) exit
+ end do
+ km1 = min(km1,k1-2)
+ do k2 = kx1(ilon,irgn)+1, kx2(ilon,irgn)+1
+ k3 = k2+1
+ tmp(ilon) = s(ilon,k2,min(k3,pverp))*min(1,pverp2-k3)
+ fdl(ilon,k2) = (1.0-emx0)*fsdl(ilon,k2) + &
+ emx0*(fclb4(ilon,km1)-s(ilon,k2,km4)+tmp(ilon))
+ end do
+ else if (ilon==indxmx(iimx,irgn) .and. iimx<=ncolmx(irgn)) then
+ iimx = iimx+1
+ end if
+!
+! Outer loop over columns with clouds in the max-overlap region
+!
+ do iimx = 1, ncolmx(irgn)
+ i = indxmx(iimx,irgn)
+
+!
+! Calculate emissivity so that downward flux at upper boundary of region
+! can be cast in form of solution for downward flux from cloud above that
+! boundary. Then solutions for fluxes at other levels take form of
+! random overlap expressions. Try to locate "cloud" as close as possible
+! to TOA such that the "cloud" pseudo-emissivity is between 0 and 1.
+!
+ k1 = kx1(i,irgn)
+ do km1 = ntoplw-2,k1-2
+ km4 = km1+3
+ k2 = k1
+ k3 = k2 + 1
+ tmp(i) = s(i,k2,min(k3,pverp))*min(1,pverp2-k3)
+ tmp2(i) = s(i,k2,min(km4,pverp))*min(1,pverp2-km4)
+ emx0 = (fdl(i,k1)-fsdl(i,k1))/((fclb4(i,km1)-tmp2(i)+tmp(i))-fsdl(i,k1))
+ if (emx0 >= 0.0 .and. emx0 <= 1.0) exit
+ end do
+ km1 = min(km1,k1-2)
+ ksort(0) = km1 + 1
+!
+! Loop to calculate fluxes at level k
+!
+ nxsk = 0
+ do k = kx1(i,irgn), kx2(i,irgn)
+!
+! Identify clouds (largest to smallest area) between kx1 and k
+! Since nxsk will increase with increasing k up to nxs(i,irgn), once
+! nxsk == nxs(i,irgn) then use the list constructed for previous k
+!
+ if (nxsk < nxs(i,irgn)) then
+ nxsk = 0
+ do l = 1, nxs(i,irgn)
+ k1 = kxs(l,i,irgn)
+ if (k >= k1) then
+ nxsk = nxsk + 1
+ ksort(nxsk) = k1
+ endif
+ end do
+ endif
+!
+! Dummy value of index to insure computation of cloud amt is valid for l=nxsk+1
+!
+ ksort(nxsk+1) = pverp
+!
+! Initialize iterated emissivity factors
+!
+ do l = 1, nxsk
+ emx(l) = emis(i,ksort(l))
+ end do
+!
+! Initialize iterated emissivity factor for bnd. condition at upper interface
+!
+ emx(0) = emx0
+!
+! Initialize previous cloud amounts
+!
+ cld0 = 1.0
+!
+! Indices for flux calculations
+!
+ k2 = k+1
+ k3 = k2+1
+ tmp(i) = s(i,k2,min(k3,pverp))*min(1,pverp2-k3)
+!
+! Loop over number of cloud levels inside region (biggest to smallest cld area)
+!
+ do l = 1, nxsk+1
+!
+! Calculate downward fluxes
+!
+ cld1 = cldp(i,ksort(l))*min(1,nxsk+1-l)
+ if (cld0 /= cld1) then
+ fdl(i,k2) = fdl(i,k2)+(cld0-cld1)*fsdl(i,k2)
+ do l1 = 0, l - 1
+ km1 = ksort(l1)-1
+ km4 = km1+3
+ tmp2(i) = s(i,k2,min(km4,pverp))* min(1,pverp2-km4)
+ fdl(i,k2) = fdl(i,k2)+(cld0-cld1)*emx(l1)*(fclb4(i,km1)-tmp2(i)+tmp(i)- &
+ fsdl(i,k2))
+ end do
+ endif
+ cld0 = cld1
+!
+! Multiply emissivity factors by current cloud transmissivity
+!
+ if (l <= nxsk) then
+ k1 = ksort(l)
+ trans = 1.0-emis(i,k1)
+!
+! Ideally the upper bound on l1 would be l-1, but the sort routine
+! scrambles the order of layers with identical cloud amounts
+!
+ do l1 = 0, nxsk
+ if (ksort(l1) < k1) then
+ emx(l1) = emx(l1)*trans
+ endif
+ end do
+ end if
+!
+! End loop over number l of cloud levels
+!
+ end do
+!
+! End loop over level k for fluxes
+!
+ end do
+!
+! End loop over longitude i for fluxes
+!
+ end do
+!
+! End loop over regions irgn for max-overlap
+!
+ end do
+
+!
+!----------------------------------------------------------------------
+! UPWARD FLUXES:
+! Outermost loop over regions (sets of adjacent layers) to be max overlapped
+!
+ do irgn = nmxrgn(ilon), 1, -1
+!
+! Compute clear-sky fluxes for regions without clouds
+!
+ iimx = 1
+ if (ilon < indxmx(iimx,irgn) .and. irgn <= nrgn(ilon)) then
+!
+! Calculate emissivity so that upward flux at lower boundary of region
+! can be cast in form of solution for upward flux from cloud below that
+! boundary. Then solutions for fluxes at other levels take form of
+! random overlap expressions. Try to locate "cloud" as close as possible
+! to surface such that the "cloud" pseudo-emissivity is between 0 and 1.
+! Include allowance for surface emissivity (both numerator and denominator
+! equal 1)
+!
+ k1 = kx2(ilon,irgn)+1
+ if (k1 < pverp) then
+ do km1 = pver-1,kx2(ilon,irgn),-1
+ km3 = km1+2
+ k2 = k1
+ k3 = k2+1
+ tmp(ilon) = s(ilon,k2,min(km3,pverp))* min(1,pverp2-km3)
+ emx0 = (ful(ilon,k1)-fsul(ilon,k1))/ &
+ ((fclt4(ilon,km1)+s(ilon,k2,k3)-tmp(ilon))- fsul(ilon,k1))
+ if (emx0 >= 0.0 .and. emx0 <= 1.0) exit
+ end do
+ km1 = max(km1,kx2(ilon,irgn))
+ else
+ km1 = k1-1
+ km3 = km1+2
+ emx0 = 1.0
+ endif
+
+ do k2 = kx1(ilon,irgn), kx2(ilon,irgn)
+ k3 = k2+1
+!
+! If km3 == pver+2, one of the s integrals = 0 (integration limits both = p_s)
+!
+ tmp(ilon) = s(ilon,k2,min(km3,pverp))* min(1,pverp2-km3)
+ ful(ilon,k2) =(1.0-emx0)*fsul(ilon,k2) + emx0* &
+ (fclt4(ilon,km1)+s(ilon,k2,k3)-tmp(ilon))
+ end do
+ else if (ilon==indxmx(iimx,irgn) .and. iimx<=ncolmx(irgn)) then
+ iimx = iimx+1
+ end if
+!
+! Outer loop over columns with clouds in the max-overlap region
+!
+ do iimx = 1, ncolmx(irgn)
+ i = indxmx(iimx,irgn)
+
+!
+! Calculate emissivity so that upward flux at lower boundary of region
+! can be cast in form of solution for upward flux from cloud at that
+! boundary. Then solutions for fluxes at other levels take form of
+! random overlap expressions. Try to locate "cloud" as close as possible
+! to surface such that the "cloud" pseudo-emissivity is between 0 and 1.
+! Include allowance for surface emissivity (both numerator and denominator
+! equal 1)
+!
+ k1 = kx2(i,irgn)+1
+ if (k1 < pverp) then
+ do km1 = pver-1,kx2(i,irgn),-1
+ km3 = km1+2
+ k2 = k1
+ k3 = k2+1
+ tmp(i) = s(i,k2,min(km3,pverp))*min(1,pverp2-km3)
+ emx0 = (ful(i,k1)-fsul(i,k1))/((fclt4(i,km1)+s(i,k2,k3)-tmp(i))-fsul(i,k1))
+ if (emx0 >= 0.0 .and. emx0 <= 1.0) exit
+ end do
+ km1 = max(km1,kx2(i,irgn))
+ else
+ emx0 = 1.0
+ km1 = k1-1
+ endif
+ ksort(0) = km1 + 1
+
+!
+! Loop to calculate fluxes at level k
+!
+ nxsk = 0
+ do k = kx2(i,irgn), kx1(i,irgn), -1
+!
+! Identify clouds (largest to smallest area) between k and kx2
+! Since nxsk will increase with decreasing k up to nxs(i,irgn), once
+! nxsk == nxs(i,irgn) then use the list constructed for previous k
+!
+ if (nxsk < nxs(i,irgn)) then
+ nxsk = 0
+ do l = 1, nxs(i,irgn)
+ k1 = kxs(l,i,irgn)
+ if (k <= k1) then
+ nxsk = nxsk + 1
+ ksort(nxsk) = k1
+ endif
+ end do
+ endif
+!
+! Dummy value of index to insure computation of cloud amt is valid for l=nxsk+1
+!
+ ksort(nxsk+1) = pverp
+!
+! Initialize iterated emissivity factors
+!
+ do l = 1, nxsk
+ emx(l) = emis(i,ksort(l))
+ end do
+!
+! Initialize iterated emissivity factor for bnd. condition at lower interface
+!
+ emx(0) = emx0
+!
+! Initialize previous cloud amounts
+!
+ cld0 = 1.0
+!
+! Indices for flux calculations
+!
+ k2 = k
+ k3 = k2+1
+!
+! Loop over number of cloud levels inside region (biggest to smallest cld area)
+!
+ do l = 1, nxsk+1
+!
+! Calculate upward fluxes
+!
+ cld1 = cldp(i,ksort(l))*min(1,nxsk+1-l)
+ if (cld0 /= cld1) then
+ ful(i,k2) = ful(i,k2)+(cld0-cld1)*fsul(i,k2)
+ do l1 = 0, l - 1
+ km1 = ksort(l1)-1
+ km3 = km1+2
+!
+! If km3 == pver+2, one of the s integrals = 0 (integration limits both = p_s)
+!
+ tmp(i) = s(i,k2,min(km3,pverp))* min(1,pverp2-km3)
+ ful(i,k2) = ful(i,k2)+(cld0-cld1)*emx(l1)* &
+ (fclt4(i,km1)+s(i,k2,k3)-tmp(i)- fsul(i,k2))
+ end do
+ endif
+ cld0 = cld1
+!
+! Multiply emissivity factors by current cloud transmissivity
+!
+ if (l <= nxsk) then
+ k1 = ksort(l)
+ trans = 1.0-emis(i,k1)
+!
+! Ideally the upper bound on l1 would be l-1, but the sort routine
+! scrambles the order of layers with identical cloud amounts
+!
+ do l1 = 0, nxsk
+ if (ksort(l1) > k1) then
+ emx(l1) = emx(l1)*trans
+ endif
+ end do
+ end if
+!
+! End loop over number l of cloud levels
+!
+ end do
+!
+! End loop over level k for fluxes
+!
+ end do
+!
+! End loop over longitude i for fluxes
+!
+ end do
+!
+! End loop over regions irgn for max-overlap
+!
+ end do
+!
+! End outermost longitude loop
+!
+ end do
+!
+! End cloud modification loops
+!
+!----------------------------------------------------------------------
+! All longitudes: store history tape quantities
+!
+ do i=1,ncol
+ flwds(i) = fdl (i,pverp )
+ flns(i) = ful (i,pverp ) - fdl (i,pverp )
+ flnsc(i) = fsul(i,pverp ) - fsdl(i,pverp )
+ flnt(i) = ful (i,ntoplw) - fdl (i,ntoplw)
+ flntc(i) = fsul(i,ntoplw) - fsdl(i,ntoplw)
+ flut(i) = ful (i,ntoplw)
+ flutc(i) = fsul(i,ntoplw)
+ end do
+!
+! Computation of longwave heating (J/kg/s)
+!
+ do k=ntoplw,pver
+ do i=1,ncol
+ qrl(i,k) = (ful(i,k) - fdl(i,k) - ful(i,k+1) + fdl(i,k+1))* &
+ 1.E-4*gravit/((pint(i,k) - pint(i,k+1)))
+ end do
+ end do
+! Return 0 above solution domain
+ if ( ntoplw > 1 )then
+ qrl(:ncol,:ntoplw-1) = 0.
+ end if
+
+! Added downward/upward total and clear sky fluxes
+!
+ do k=ntoplw,pverp
+ do i=1,ncol
+ flup(i,k) = ful(i,k)
+ flupc(i,k) = fsul(i,k)
+ fldn(i,k) = fdl(i,k)
+ fldnc(i,k) = fsdl(i,k)
+ end do
+ end do
+! Return 0 above solution domain
+ if ( ntoplw > 1 )then
+ flup(:ncol,:ntoplw-1) = 0.
+ flupc(:ncol,:ntoplw-1) = 0.
+ fldn(:ncol,:ntoplw-1) = 0.
+ fldnc(:ncol,:ntoplw-1) = 0.
+ end if
+!
+ return
+end subroutine radclwmx
+
+subroutine radcswmx(jj, lchnk ,ncol ,pcols, pver, pverp, &
+ pint ,pmid ,h2ommr ,rh ,o3mmr , &
+ aermmr ,cld ,cicewp ,cliqwp ,rel , &
+! rei ,eccf ,coszrs ,scon ,solin ,solcon, &
+ rei ,tauxcl ,tauxci ,eccf ,coszrs ,scon ,solin ,solcon, &
+ asdir ,asdif ,aldir ,aldif ,nmxrgn , &
+ pmxrgn ,qrs ,fsnt ,fsntc ,fsntoa , &
+ fsntoac ,fsnirtoa,fsnrtoac,fsnrtoaq,fsns , &
+ fsnsc ,fsdsc ,fsds ,sols ,soll , &
+ solsd ,solld ,frc_day , &
+ fsup ,fsupc ,fsdn ,fsdnc , &
+ aertau ,aerssa ,aerasm ,aerfwd )
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Solar radiation code
+!
+! Method:
+! Basic method is Delta-Eddington as described in:
+!
+! Briegleb, Bruce P., 1992: Delta-Eddington
+! Approximation for Solar Radiation in the NCAR Community Climate Model,
+! Journal of Geophysical Research, Vol 97, D7, pp7603-7612).
+!
+! Five changes to the basic method described above are:
+! (1) addition of sulfate aerosols (Kiehl and Briegleb, 1993)
+! (2) the distinction between liquid and ice particle clouds
+! (Kiehl et al, 1996);
+! (3) provision for calculating TOA fluxes with spectral response to
+! match Nimbus-7 visible/near-IR radiometers (Collins, 1998);
+! (4) max-random overlap (Collins, 2001)
+! (5) The near-IR absorption by H2O was updated in 2003 by Collins,
+! Lee-Taylor, and Edwards for consistency with the new line data in
+! Hitran 2000 and the H2O continuum version CKD 2.4. Modifications
+! were optimized by reducing RMS errors in heating rates relative
+! to a series of benchmark calculations for the 5 standard AFGL
+! atmospheres. The benchmarks were performed using DISORT2 combined
+! with GENLN3. The near-IR scattering optical depths for Rayleigh
+! scattering were also adjusted, as well as the correction for
+! stratospheric heating by H2O.
+!
+! The treatment of maximum-random overlap is described in the
+! comment block "INDEX CALCULATIONS FOR MAX OVERLAP".
+!
+! Divides solar spectrum into 19 intervals from 0.2-5.0 micro-meters.
+! solar flux fractions specified for each interval. allows for
+! seasonally and diurnally varying solar input. Includes molecular,
+! cloud, aerosol, and surface scattering, along with h2o,o3,co2,o2,cloud,
+! and surface absorption. Computes delta-eddington reflections and
+! transmissions assuming homogeneously mixed layers. Adds the layers
+! assuming scattering between layers to be isotropic, and distinguishes
+! direct solar beam from scattered radiation.
+!
+! Longitude loops are broken into 1 or 2 sections, so that only daylight
+! (i.e. coszrs > 0) computations are done.
+!
+! Note that an extra layer above the model top layer is added.
+!
+! cgs units are used.
+!
+! Special diagnostic calculation of the clear sky surface and total column
+! absorbed flux is also done for cloud forcing diagnostics.
+!
+!-----------------------------------------------------------------------
+! use shr_kind_mod, only: r8 => shr_kind_r8
+! use ppgrid
+! use ghg_surfvals, only: co2mmr
+! use prescribed_aerosols, only: idxBG, idxSUL, idxSSLT, idxOCPHO, idxBCPHO, idxOCPHI, idxBCPHI, &
+! idxDUSTfirst, numDUST, idxVOLC, naer_all
+! use aer_optics, only: nrh, ndstsz, ksul, wsul, gsul, &
+! ksslt, wsslt, gsslt, kcphil, wcphil, gcphil, kcphob, wcphob, gcphob, &
+! kcb, wcb, gcb, kdst, wdst, gdst, kbg, wbg, gbg, kvolc, wvolc, gvolc
+! use abortutils, only: endrun
+
+ implicit none
+
+ integer nspint ! Num of spctrl intervals across solar spectrum
+ integer naer_groups ! Num of aerosol groups for optical diagnostics
+
+ parameter ( nspint = 19 )
+ parameter ( naer_groups = 7 ) ! current groupings are sul, sslt, all carbons, all dust, and all aerosols
+!-----------------------Constants for new band (640-700 nm)-------------
+
+!-------------Parameters for accelerating max-random solution-------------
+!
+! The solution time scales like prod(j:1->N) (1 + n_j) where
+! N = number of max-overlap regions (nmxrgn)
+! n_j = number of unique cloud amounts in region j
+!
+! Therefore the solution cost can be reduced by decreasing n_j.
+! cldmin reduces n_j by treating cloud amounts < cldmin as clear sky.
+! cldeps reduces n_j by treating cloud amounts identical to log(1/cldeps)
+! decimal places as identical
+!
+! areamin reduces the cost by dropping configurations that occupy
+! a surface area < areamin of the model grid box. The surface area
+! for a configuration C(j,k_j), where j is the region number and k_j is the
+! index for a unique cloud amount (in descending order from biggest to
+! smallest clouds) in region j, is
+!
+! A = prod(j:1->N) [C(j,k_j) - C(j,k_j+1)]
+!
+! where C(j,0) = 1.0 and C(j,n_j+1) = 0.0.
+!
+! nconfgmax reduces the cost and improves load balancing by setting an upper
+! bound on the number of cloud configurations in the solution. If the number
+! of configurations exceeds nconfgmax, the nconfgmax configurations with the
+! largest area are retained, and the fluxes are normalized by the total area
+! of these nconfgmax configurations. For the current max/random overlap
+! assumption (see subroutine cldovrlap), 30 levels, and cloud-amount
+! parameterization, the mean and RMS number of configurations are
+! both roughly 5. nconfgmax has been set to the mean+2*RMS number, or 15.
+!
+! Minimum cloud amount (as a fraction of the grid-box area) to
+! distinguish from clear sky
+!
+ real(r8) cldmin
+ parameter (cldmin = 1.0e-80_r8)
+!
+! Minimimum horizontal area (as a fraction of the grid-box area) to retain
+! for a unique cloud configuration in the max-random solution
+!
+ real(r8) areamin
+ parameter (areamin = 0.01_r8)
+!
+! Decimal precision of cloud amount (0 -> preserve full resolution;
+! 10^-n -> preserve n digits of cloud amount)
+!
+ real(r8) cldeps
+ parameter (cldeps = 0.0_r8)
+!
+! Maximum number of configurations to include in solution
+!
+ integer nconfgmax
+ parameter (nconfgmax = 15)
+!------------------------------Commons----------------------------------
+!
+! Input arguments
+!
+ integer, intent(in) :: lchnk,jj ! chunk identifier
+ integer, intent(in) :: pcols, pver, pverp
+ integer, intent(in) :: ncol ! number of atmospheric columns
+
+ real(r8), intent(in) :: pmid(pcols,pver) ! Level pressure
+ real(r8), intent(in) :: pint(pcols,pverp) ! Interface pressure
+ real(r8), intent(in) :: h2ommr(pcols,pver) ! Specific humidity (h2o mass mix ratio)
+ real(r8), intent(in) :: o3mmr(pcols,pver) ! Ozone mass mixing ratio
+ real(r8), intent(in) :: aermmr(pcols,pver,naer_all) ! Aerosol mass mixing ratio
+ real(r8), intent(in) :: rh(pcols,pver) ! Relative humidity (fraction)
+!
+ real(r8), intent(in) :: cld(pcols,pver) ! Fractional cloud cover
+ real(r8), intent(in) :: cicewp(pcols,pver) ! in-cloud cloud ice water path
+ real(r8), intent(in) :: cliqwp(pcols,pver) ! in-cloud cloud liquid water path
+ real(r8), intent(in) :: rel(pcols,pver) ! Liquid effective drop size (microns)
+ real(r8), intent(in) :: rei(pcols,pver) ! Ice effective drop size (microns)
+!
+ real(r8), intent(in) :: eccf ! Eccentricity factor (1./earth-sun dist^2)
+ real, intent(in) :: solcon ! solar constant with eccentricity factor
+ real(r8), intent(in) :: coszrs(pcols) ! Cosine solar zenith angle
+ real(r8), intent(in) :: asdir(pcols) ! 0.2-0.7 micro-meter srfc alb: direct rad
+ real(r8), intent(in) :: aldir(pcols) ! 0.7-5.0 micro-meter srfc alb: direct rad
+ real(r8), intent(in) :: asdif(pcols) ! 0.2-0.7 micro-meter srfc alb: diffuse rad
+ real(r8), intent(in) :: aldif(pcols) ! 0.7-5.0 micro-meter srfc alb: diffuse rad
+
+ real(r8), intent(in) :: scon ! solar constant
+!
+! IN/OUT arguments
+!
+ real(r8), intent(inout) :: pmxrgn(pcols,pverp) ! Maximum values of pressure for each
+! ! maximally overlapped region.
+! ! 0->pmxrgn(i,1) is range of pressure for
+! ! 1st region,pmxrgn(i,1)->pmxrgn(i,2) for
+! ! 2nd region, etc
+ integer, intent(inout) :: nmxrgn(pcols) ! Number of maximally overlapped regions
+!
+! Output arguments
+!
+
+ real(r8), intent(out) :: solin(pcols) ! Incident solar flux
+ real(r8), intent(out) :: qrs(pcols,pver) ! Solar heating rate
+ real(r8), intent(out) :: fsns(pcols) ! Surface absorbed solar flux
+ real(r8), intent(out) :: fsnt(pcols) ! Total column absorbed solar flux
+ real(r8), intent(out) :: fsntoa(pcols) ! Net solar flux at TOA
+ real(r8), intent(out) :: fsds(pcols) ! Flux shortwave downwelling surface
+!
+ real(r8), intent(out) :: fsnsc(pcols) ! Clear sky surface absorbed solar flux
+ real(r8), intent(out) :: fsdsc(pcols) ! Clear sky surface downwelling solar flux
+ real(r8), intent(out) :: fsntc(pcols) ! Clear sky total column absorbed solar flx
+ real(r8), intent(out) :: fsntoac(pcols) ! Clear sky net solar flx at TOA
+ real(r8), intent(out) :: sols(pcols) ! Direct solar rad on surface (< 0.7)
+ real(r8), intent(out) :: soll(pcols) ! Direct solar rad on surface (>= 0.7)
+ real(r8), intent(out) :: solsd(pcols) ! Diffuse solar rad on surface (< 0.7)
+ real(r8), intent(out) :: solld(pcols) ! Diffuse solar rad on surface (>= 0.7)
+ real(r8), intent(out) :: fsnirtoa(pcols) ! Near-IR flux absorbed at toa
+ real(r8), intent(out) :: fsnrtoac(pcols) ! Clear sky near-IR flux absorbed at toa
+ real(r8), intent(out) :: fsnrtoaq(pcols) ! Net near-IR flux at toa >= 0.7 microns
+ real(r8), intent(out) :: tauxcl(pcols,0:pver) ! water cloud extinction optical depth
+ real(r8), intent(out) :: tauxci(pcols,0:pver) ! ice cloud extinction optical depth
+
+! Added downward/upward total and clear sky fluxes
+ real(r8), intent(out) :: fsup(pcols,pverp) ! Total sky upward solar flux (spectrally summed)
+ real(r8), intent(out) :: fsupc(pcols,pverp) ! Clear sky upward solar flux (spectrally summed)
+ real(r8), intent(out) :: fsdn(pcols,pverp) ! Total sky downward solar flux (spectrally summed)
+ real(r8), intent(out) :: fsdnc(pcols,pverp) ! Clear sky downward solar flux (spectrally summed)
+!
+ real(r8) , intent(out) :: frc_day(pcols) ! = 1 for daylight, =0 for night columns
+ real(r8) :: aertau(pcols,nspint,naer_groups) ! Aerosol column optical depth
+ real(r8) :: aerssa(pcols,nspint,naer_groups) ! Aerosol column averaged single scattering albedo
+ real(r8) :: aerasm(pcols,nspint,naer_groups) ! Aerosol column averaged asymmetry parameter
+ real(r8) :: aerfwd(pcols,nspint,naer_groups) ! Aerosol column averaged forward scattering
+! real(r8), intent(out) :: aertau(pcols,nspint,naer_groups) ! Aerosol column optical depth
+! real(r8), intent(out) :: aerssa(pcols,nspint,naer_groups) ! Aerosol column averaged single scattering albedo
+! real(r8), intent(out) :: aerasm(pcols,nspint,naer_groups) ! Aerosol column averaged asymmetry parameter
+! real(r8), intent(out) :: aerfwd(pcols,nspint,naer_groups) ! Aerosol column averaged forward scattering
+!
+!---------------------------Local variables-----------------------------
+!
+! Max/random overlap variables
+!
+ real(r8) asort(pverp) ! 1 - cloud amounts to be sorted for max ovrlp.
+ real(r8) atmp ! Temporary storage for sort when nxs = 2
+ real(r8) cld0 ! 1 - (cld amt) used to make wstr, cstr, nstr
+ real(r8) totwgt ! Total of xwgts = total fractional area of
+! grid-box covered by cloud configurations
+! included in solution to fluxes
+
+ real(r8) wgtv(nconfgmax) ! Weights for fluxes
+! 1st index is configuration number
+ real(r8) wstr(pverp,pverp) ! area weighting factors for streams
+! 1st index is for stream #,
+! 2nd index is for region #
+
+ real(r8) xexpt ! solar direct beam trans. for layer above
+ real(r8) xrdnd ! diffuse reflectivity for layer above
+ real(r8) xrupd ! diffuse reflectivity for layer below
+ real(r8) xrups ! direct-beam reflectivity for layer below
+ real(r8) xtdnt ! total trans for layers above
+
+ real(r8) xwgt ! product of cloud amounts
+
+ real(r8) yexpt ! solar direct beam trans. for layer above
+ real(r8) yrdnd ! diffuse reflectivity for layer above
+ real(r8) yrupd ! diffuse reflectivity for layer below
+ real(r8) ytdnd ! dif-beam transmission for layers above
+ real(r8) ytupd ! dif-beam transmission for layers below
+
+ real(r8) zexpt ! solar direct beam trans. for layer above
+ real(r8) zrdnd ! diffuse reflectivity for layer above
+ real(r8) zrupd ! diffuse reflectivity for layer below
+ real(r8) zrups ! direct-beam reflectivity for layer below
+ real(r8) ztdnt ! total trans for layers above
+
+ logical new_term ! Flag for configurations to include in fluxes
+ logical region_found ! flag for identifying regions
+
+ integer ccon(0:pverp,nconfgmax)
+! flags for presence of clouds
+! 1st index is for level # (including
+! layer above top of model and at surface)
+! 2nd index is for configuration #
+ integer cstr(0:pverp,pverp)
+! flags for presence of clouds
+! 1st index is for level # (including
+! layer above top of model and at surface)
+! 2nd index is for stream #
+ integer icond(0:pverp,nconfgmax)
+! Indices for copying rad. properties from
+! one identical downward cld config.
+! to another in adding method (step 2)
+! 1st index is for interface # (including
+! layer above top of model and at surface)
+! 2nd index is for configuration # range
+ integer iconu(0:pverp,nconfgmax)
+! Indices for copying rad. properties from
+! one identical upward configuration
+! to another in adding method (step 2)
+! 1st index is for interface # (including
+! layer above top of model and at surface)
+! 2nd index is for configuration # range
+ integer iconfig ! Counter for random-ovrlap configurations
+ integer irgn ! Index for max-overlap regions
+ integer is0 ! Lower end of stream index range
+ integer is1 ! Upper end of stream index range
+ integer isn ! Stream index
+ integer istr(pverp+1) ! index for stream #s during flux calculation
+ integer istrtd(0:pverp,0:nconfgmax+1)
+! indices into icond
+! 1st index is for interface # (including
+! layer above top of model and at surface)
+! 2nd index is for configuration # range
+ integer istrtu(0:pverp,0:nconfgmax+1)
+! indices into iconu
+! 1st index is for interface # (including
+! layer above top of model and at surface)
+! 2nd index is for configuration # range
+ integer j ! Configuration index
+ integer k1 ! Level index
+ integer k2 ! Level index
+ integer ksort(pverp) ! Level indices of cloud amounts to be sorted
+ integer ktmp ! Temporary storage for sort when nxs = 2
+ integer kx1(0:pverp) ! Level index for top of max-overlap region
+ integer kx2(0:pverp) ! Level index for bottom of max-overlap region
+ integer l ! Index
+ integer l0 ! Index
+ integer mrgn ! Counter for nrgn
+ integer mstr ! Counter for nstr
+ integer n0 ! Number of configurations with ccon(k,:)==0
+ integer n1 ! Number of configurations with ccon(k,:)==1
+ integer nconfig ! Number of random-ovrlap configurations
+ integer nconfigm ! Value of config before testing for areamin,
+! nconfgmax
+ integer npasses ! number of passes over the indexing loop
+ integer nrgn ! Number of max overlap regions at current
+! longitude
+ integer nstr(pverp) ! Number of unique cloud configurations
+! ("streams") in a max-overlapped region
+! 1st index is for region #
+ integer nuniq ! # of unique cloud configurations
+ integer nuniqd(0:pverp) ! # of unique cloud configurations: TOA
+! to level k
+ integer nuniqu(0:pverp) ! # of unique cloud configurations: surface
+! to level k
+ integer nxs ! Number of cloudy layers between k1 and k2
+ integer ptr0(nconfgmax) ! Indices of configurations with ccon(k,:)==0
+ integer ptr1(nconfgmax) ! Indices of configurations with ccon(k,:)==1
+ integer ptrc(nconfgmax) ! Pointer for configurations sorted by wgtv
+! integer findvalue ! Function for finding kth smallest element
+! in a vector
+! external findvalue
+
+!
+! Other
+!
+ integer ns ! Spectral loop index
+ integer i ! Longitude loop index
+ integer k ! Level loop index
+ integer km1 ! k - 1
+ integer kp1 ! k + 1
+ integer n ! Loop index for daylight
+ integer ndayc ! Number of daylight columns
+ integer idayc(pcols) ! Daytime column indices
+ integer indxsl ! Index for cloud particle properties
+ integer ksz ! dust size bin index
+ integer krh ! relative humidity bin index
+ integer kaer ! aerosol group index
+ real(r8) wrh ! weight for linear interpolation between lut points
+ real(r8) :: rhtrunc ! rh, truncated for the purposes of extrapolating
+ ! aerosol optical properties
+ real(r8) albdir(pcols,nspint) ! Current spc intrvl srf alb to direct rad
+ real(r8) albdif(pcols,nspint) ! Current spc intrvl srf alb to diffuse rad
+!
+ real(r8) wgtint ! Weight for specific spectral interval
+
+!
+! Diagnostic and accumulation arrays; note that sfltot, fswup, and
+! fswdn are not used in the computation,but are retained for future use.
+!
+ real(r8) solflx ! Solar flux in current interval
+ real(r8) sfltot ! Spectrally summed total solar flux
+ real(r8) totfld(0:pver) ! Spectrally summed flux divergence
+ real(r8) fswup(0:pverp) ! Spectrally summed up flux
+ real(r8) fswdn(0:pverp) ! Spectrally summed down flux
+ real(r8) fswupc(0:pverp) ! Spectrally summed up clear sky flux
+ real(r8) fswdnc(0:pverp) ! Spectrally summed down clear sky flux
+!
+! Cloud radiative property arrays
+!
+! real(r8) tauxcl(pcols,0:pver) ! water cloud extinction optical depth
+! real(r8) tauxci(pcols,0:pver) ! ice cloud extinction optical depth
+ real(r8) wcl(pcols,0:pver) ! liquid cloud single scattering albedo
+ real(r8) gcl(pcols,0:pver) ! liquid cloud asymmetry parameter
+ real(r8) fcl(pcols,0:pver) ! liquid cloud forward scattered fraction
+ real(r8) wci(pcols,0:pver) ! ice cloud single scattering albedo
+ real(r8) gci(pcols,0:pver) ! ice cloud asymmetry parameter
+ real(r8) fci(pcols,0:pver) ! ice cloud forward scattered fraction
+!
+! Aerosol mass paths by species
+!
+ real(r8) usul(pcols,pver) ! sulfate (SO4)
+ real(r8) ubg(pcols,pver) ! background aerosol
+ real(r8) usslt(pcols,pver) ! sea-salt (SSLT)
+ real(r8) ucphil(pcols,pver) ! hydrophilic organic carbon (OCPHI)
+ real(r8) ucphob(pcols,pver) ! hydrophobic organic carbon (OCPHO)
+ real(r8) ucb(pcols,pver) ! black carbon (BCPHI + BCPHO)
+ real(r8) uvolc(pcols,pver) ! volcanic mass
+ real(r8) udst(ndstsz,pcols,pver) ! dust
+
+!
+! local variables used for the external mixing of aerosol species
+!
+ real(r8) tau_sul ! optical depth, sulfate
+ real(r8) tau_bg ! optical depth, background aerosol
+ real(r8) tau_sslt ! optical depth, sea-salt
+ real(r8) tau_cphil ! optical depth, hydrophilic carbon
+ real(r8) tau_cphob ! optical depth, hydrophobic carbon
+ real(r8) tau_cb ! optical depth, black carbon
+ real(r8) tau_volc ! optical depth, volcanic
+ real(r8) tau_dst(ndstsz) ! optical depth, dust, by size category
+ real(r8) tau_dst_tot ! optical depth, total dust
+ real(r8) tau_tot ! optical depth, total aerosol
+
+ real(r8) tau_w_sul ! optical depth * single scattering albedo, sulfate
+ real(r8) tau_w_bg ! optical depth * single scattering albedo, background aerosol
+ real(r8) tau_w_sslt ! optical depth * single scattering albedo, sea-salt
+ real(r8) tau_w_cphil ! optical depth * single scattering albedo, hydrophilic carbon
+ real(r8) tau_w_cphob ! optical depth * single scattering albedo, hydrophobic carbon
+ real(r8) tau_w_cb ! optical depth * single scattering albedo, black carbon
+ real(r8) tau_w_volc ! optical depth * single scattering albedo, volcanic
+ real(r8) tau_w_dst(ndstsz) ! optical depth * single scattering albedo, dust, by size
+ real(r8) tau_w_dst_tot ! optical depth * single scattering albedo, total dust
+ real(r8) tau_w_tot ! optical depth * single scattering albedo, total aerosol
+
+ real(r8) tau_w_g_sul ! optical depth * single scattering albedo * asymmetry parameter, sulfate
+ real(r8) tau_w_g_bg ! optical depth * single scattering albedo * asymmetry parameter, background aerosol
+ real(r8) tau_w_g_sslt ! optical depth * single scattering albedo * asymmetry parameter, sea-salt
+ real(r8) tau_w_g_cphil ! optical depth * single scattering albedo * asymmetry parameter, hydrophilic carbon
+ real(r8) tau_w_g_cphob ! optical depth * single scattering albedo * asymmetry parameter, hydrophobic carbon
+ real(r8) tau_w_g_cb ! optical depth * single scattering albedo * asymmetry parameter, black carbon
+ real(r8) tau_w_g_volc ! optical depth * single scattering albedo * asymmetry parameter, volcanic
+ real(r8) tau_w_g_dst(ndstsz) ! optical depth * single scattering albedo * asymmetry parameter, dust, by size
+ real(r8) tau_w_g_dst_tot ! optical depth * single scattering albedo * asymmetry parameter, total dust
+ real(r8) tau_w_g_tot ! optical depth * single scattering albedo * asymmetry parameter, total aerosol
+
+ real(r8) f_sul ! forward scattering fraction, sulfate
+ real(r8) f_bg ! forward scattering fraction, background aerosol
+ real(r8) f_sslt ! forward scattering fraction, sea-salt
+ real(r8) f_cphil ! forward scattering fraction, hydrophilic carbon
+ real(r8) f_cphob ! forward scattering fraction, hydrophobic carbon
+ real(r8) f_cb ! forward scattering fraction, black carbon
+ real(r8) f_volc ! forward scattering fraction, volcanic
+ real(r8) f_dst(ndstsz) ! forward scattering fraction, dust, by size
+ real(r8) f_dst_tot ! forward scattering fraction, total dust
+ real(r8) f_tot ! forward scattering fraction, total aerosol
+
+ real(r8) tau_w_f_sul ! optical depth * forward scattering fraction * single scattering albedo, sulfate
+ real(r8) tau_w_f_bg ! optical depth * forward scattering fraction * single scattering albedo, background
+ real(r8) tau_w_f_sslt ! optical depth * forward scattering fraction * single scattering albedo, sea-salt
+ real(r8) tau_w_f_cphil ! optical depth * forward scattering fraction * single scattering albedo, hydrophilic C
+ real(r8) tau_w_f_cphob ! optical depth * forward scattering fraction * single scattering albedo, hydrophobic C
+ real(r8) tau_w_f_cb ! optical depth * forward scattering fraction * single scattering albedo, black C
+ real(r8) tau_w_f_volc ! optical depth * forward scattering fraction * single scattering albedo, volcanic
+ real(r8) tau_w_f_dst(ndstsz) ! optical depth * forward scattering fraction * single scattering albedo, dust, by size
+ real(r8) tau_w_f_dst_tot ! optical depth * forward scattering fraction * single scattering albedo, total dust
+ real(r8) tau_w_f_tot ! optical depth * forward scattering fraction * single scattering albedo, total aerosol
+ real(r8) w_dst_tot ! single scattering albedo, total dust
+ real(r8) w_tot ! single scattering albedo, total aerosol
+ real(r8) g_dst_tot ! asymmetry parameter, total dust
+ real(r8) g_tot ! asymmetry parameter, total aerosol
+ real(r8) ksuli ! specific extinction interpolated between rh look-up-table points, sulfate
+ real(r8) ksslti ! specific extinction interpolated between rh look-up-table points, sea-salt
+ real(r8) kcphili ! specific extinction interpolated between rh look-up-table points, hydrophilic carbon
+ real(r8) wsuli ! single scattering albedo interpolated between rh look-up-table points, sulfate
+ real(r8) wsslti ! single scattering albedo interpolated between rh look-up-table points, sea-salt
+ real(r8) wcphili ! single scattering albedo interpolated between rh look-up-table points, hydrophilic carbon
+ real(r8) gsuli ! asymmetry parameter interpolated between rh look-up-table points, sulfate
+ real(r8) gsslti ! asymmetry parameter interpolated between rh look-up-table points, sea-salt
+ real(r8) gcphili ! asymmetry parameter interpolated between rh look-up-table points, hydrophilic carbon
+!
+! Aerosol radiative property arrays
+!
+ real(r8) tauxar(pcols,0:pver) ! aerosol extinction optical depth
+ real(r8) wa(pcols,0:pver) ! aerosol single scattering albedo
+ real(r8) ga(pcols,0:pver) ! aerosol assymetry parameter
+ real(r8) fa(pcols,0:pver) ! aerosol forward scattered fraction
+
+!
+! Various arrays and other constants:
+!
+ real(r8) pflx(pcols,0:pverp) ! Interface press, including extra layer
+ real(r8) zenfac(pcols) ! Square root of cos solar zenith angle
+ real(r8) sqrco2 ! Square root of the co2 mass mixg ratio
+ real(r8) tmp1 ! Temporary constant array
+ real(r8) tmp2 ! Temporary constant array
+ real(r8) pdel ! Pressure difference across layer
+ real(r8) path ! Mass path of layer
+ real(r8) ptop ! Lower interface pressure of extra layer
+ real(r8) ptho2 ! Used to compute mass path of o2
+ real(r8) ptho3 ! Used to compute mass path of o3
+ real(r8) pthco2 ! Used to compute mass path of co2
+ real(r8) pthh2o ! Used to compute mass path of h2o
+ real(r8) h2ostr ! Inverse sq. root h2o mass mixing ratio
+ real(r8) wavmid(nspint) ! Spectral interval middle wavelength
+ real(r8) trayoslp ! Rayleigh optical depth/standard pressure
+ real(r8) tmp1l ! Temporary constant array
+ real(r8) tmp2l ! Temporary constant array
+ real(r8) tmp3l ! Temporary constant array
+ real(r8) tmp1i ! Temporary constant array
+ real(r8) tmp2i ! Temporary constant array
+ real(r8) tmp3i ! Temporary constant array
+ real(r8) rdenom ! Multiple scattering term
+ real(r8) rdirexp ! layer direct ref times exp transmission
+ real(r8) tdnmexp ! total transmission - exp transmission
+ real(r8) psf(nspint) ! Frac of solar flux in spect interval
+!
+! Layer absorber amounts; note that 0 refers to the extra layer added
+! above the top model layer
+!
+ real(r8) uh2o(pcols,0:pver) ! Layer absorber amount of h2o
+ real(r8) uo3(pcols,0:pver) ! Layer absorber amount of o3
+ real(r8) uco2(pcols,0:pver) ! Layer absorber amount of co2
+ real(r8) uo2(pcols,0:pver) ! Layer absorber amount of o2
+ real(r8) uaer(pcols,0:pver) ! Layer aerosol amount
+!
+! Total column absorber amounts:
+!
+ real(r8) uth2o(pcols) ! Total column absorber amount of h2o
+ real(r8) uto3(pcols) ! Total column absorber amount of o3
+ real(r8) utco2(pcols) ! Total column absorber amount of co2
+ real(r8) uto2(pcols) ! Total column absorber amount of o2
+!
+! These arrays are defined for pver model layers; 0 refers to the extra
+! layer on top:
+!
+ real(r8) rdir(nspint,pcols,0:pver) ! Layer reflectivity to direct rad
+ real(r8) rdif(nspint,pcols,0:pver) ! Layer reflectivity to diffuse rad
+ real(r8) tdir(nspint,pcols,0:pver) ! Layer transmission to direct rad
+ real(r8) tdif(nspint,pcols,0:pver) ! Layer transmission to diffuse rad
+ real(r8) explay(nspint,pcols,0:pver) ! Solar beam exp trans. for layer
+
+ real(r8) rdirc(nspint,pcols,0:pver) ! Clear Layer reflec. to direct rad
+ real(r8) rdifc(nspint,pcols,0:pver) ! Clear Layer reflec. to diffuse rad
+ real(r8) tdirc(nspint,pcols,0:pver) ! Clear Layer trans. to direct rad
+ real(r8) tdifc(nspint,pcols,0:pver) ! Clear Layer trans. to diffuse rad
+ real(r8) explayc(nspint,pcols,0:pver) ! Solar beam exp trans. clear layer
+
+ real(r8) flxdiv ! Flux divergence for layer
+!
+!
+! Radiative Properties:
+!
+! There are 1 classes of properties:
+! (1. All-sky bulk properties
+! (2. Clear-sky properties
+!
+! The first set of properties are generated during step 2 of the solution.
+!
+! These arrays are defined at model interfaces; in 1st index (for level #),
+! 0 is the top of the extra layer above the model top, and
+! pverp is the earth surface. 2nd index is for cloud configuration
+! defined over a whole column.
+!
+ real(r8) exptdn(0:pverp,nconfgmax) ! Sol. beam trans from layers above
+ real(r8) rdndif(0:pverp,nconfgmax) ! Ref to dif rad for layers above
+ real(r8) rupdif(0:pverp,nconfgmax) ! Ref to dif rad for layers below
+ real(r8) rupdir(0:pverp,nconfgmax) ! Ref to dir rad for layers below
+ real(r8) tdntot(0:pverp,nconfgmax) ! Total trans for layers above
+!
+! Bulk properties used during the clear-sky calculation.
+!
+ real(r8) exptdnc(0:pverp) ! clr: Sol. beam trans from layers above
+ real(r8) rdndifc(0:pverp) ! clr: Ref to dif rad for layers above
+ real(r8) rupdifc(0:pverp) ! clr: Ref to dif rad for layers below
+ real(r8) rupdirc(0:pverp) ! clr: Ref to dir rad for layers below
+ real(r8) tdntotc(0:pverp) ! clr: Total trans for layers above
+
+ real(r8) fluxup(0:pverp) ! Up flux at model interface
+ real(r8) fluxdn(0:pverp) ! Down flux at model interface
+ real(r8) wexptdn ! Direct solar beam trans. to surface
+
+! moved to here from the module storage above, because these have to be thread-private. JM 20100217
+ real(r8) abarli ! A coefficient for current spectral band
+ real(r8) bbarli ! B coefficient for current spectral band
+ real(r8) cbarli ! C coefficient for current spectral band
+ real(r8) dbarli ! D coefficient for current spectral band
+ real(r8) ebarli ! E coefficient for current spectral band
+ real(r8) fbarli ! F coefficient for current spectral band
+
+ real(r8) abarii ! A coefficient for current spectral band
+ real(r8) bbarii ! B coefficient for current spectral band
+ real(r8) cbarii ! C coefficient for current spectral band
+ real(r8) dbarii ! D coefficient for current spectral band
+ real(r8) ebarii ! E coefficient for current spectral band
+ real(r8) fbarii ! F coefficient for current spectral band
+! JM 20100217
+
+!
+!-----------------------------------------------------------------------
+! START OF CALCULATION
+!-----------------------------------------------------------------------
+!
+! write (6, '(a, x, i3)') 'radcswmx : chunk identifier', lchnk
+
+ do i=1, ncol
+!
+! Initialize output fields:
+!
+ fsds(i) = 0.0_r8
+
+ fsnirtoa(i) = 0.0_r8
+ fsnrtoac(i) = 0.0_r8
+ fsnrtoaq(i) = 0.0_r8
+
+ fsns(i) = 0.0_r8
+ fsnsc(i) = 0.0_r8
+ fsdsc(i) = 0.0_r8
+
+ fsnt(i) = 0.0_r8
+ fsntc(i) = 0.0_r8
+ fsntoa(i) = 0.0_r8
+ fsntoac(i) = 0.0_r8
+
+ solin(i) = 0.0_r8
+
+ sols(i) = 0.0_r8
+ soll(i) = 0.0_r8
+ solsd(i) = 0.0_r8
+ solld(i) = 0.0_r8
+
+! initialize added downward/upward total and clear sky fluxes
+
+ do k=1,pverp
+ fsup(i,k) = 0.0_r8
+ fsupc(i,k) = 0.0_r8
+ fsdn(i,k) = 0.0_r8
+ fsdnc(i,k) = 0.0_r8
+ tauxcl(i,k-1) = 0.0_r8
+ tauxci(i,k-1) = 0.0_r8
+ end do
+
+ do k=1, pver
+ qrs(i,k) = 0.0_r8
+ end do
+
+ ! initialize aerosol diagnostic fields to 0.0
+ ! Average can be obtained by dividing <aerod>/<frc_day>
+ do kaer = 1, naer_groups
+ do ns = 1, nspint
+ frc_day(i) = 0.0_r8
+ aertau(i,ns,kaer) = 0.0_r8
+ aerssa(i,ns,kaer) = 0.0_r8
+ aerasm(i,ns,kaer) = 0.0_r8
+ aerfwd(i,ns,kaer) = 0.0_r8
+ end do
+ end do
+
+ end do
+!
+! Compute starting, ending daytime loop indices:
+! *** Note this logic assumes day and night points are contiguous so
+! *** will not work in general with chunked data structure.
+!
+ ndayc = 0
+ do i=1,ncol
+ if (coszrs(i) > 0.0_r8) then
+ ndayc = ndayc + 1
+ idayc(ndayc) = i
+ end if
+ end do
+!
+! If night everywhere, return:
+!
+ if (ndayc == 0) return
+!
+! Perform other initializations
+!
+ tmp1 = 0.5_r8/(gravit*sslp)
+ tmp2 = delta/gravit
+ sqrco2 = sqrt(co2mmr)
+
+ do n=1,ndayc
+ i=idayc(n)
+!
+! Define solar incident radiation and interface pressures:
+!
+! solin(i) = scon*eccf*coszrs(i)
+!WRF use SOLCON (MKS) calculated outside
+ solin(i) = solcon*coszrs(i)*1000.
+ pflx(i,0) = 0._r8
+ do k=1,pverp
+ pflx(i,k) = pint(i,k)
+ end do
+!
+! Compute optical paths:
+!
+ ptop = pflx(i,1)
+ ptho2 = o2mmr * ptop / gravit
+ ptho3 = o3mmr(i,1) * ptop / gravit
+ pthco2 = sqrco2 * (ptop / gravit)
+ h2ostr = sqrt( 1._r8 / h2ommr(i,1) )
+ zenfac(i) = sqrt(coszrs(i))
+ pthh2o = ptop**2*tmp1 + (ptop*rga)* &
+ (h2ostr*zenfac(i)*delta)
+ uh2o(i,0) = h2ommr(i,1)*pthh2o
+ uco2(i,0) = zenfac(i)*pthco2
+ uo2 (i,0) = zenfac(i)*ptho2
+ uo3 (i,0) = ptho3
+ uaer(i,0) = 0.0_r8
+ do k=1,pver
+ pdel = pflx(i,k+1) - pflx(i,k)
+ path = pdel / gravit
+ ptho2 = o2mmr * path
+ ptho3 = o3mmr(i,k) * path
+ pthco2 = sqrco2 * path
+ h2ostr = sqrt(1.0_r8/h2ommr(i,k))
+ pthh2o = (pflx(i,k+1)**2 - pflx(i,k)**2)*tmp1 + pdel*h2ostr*zenfac(i)*tmp2
+ uh2o(i,k) = h2ommr(i,k)*pthh2o
+ uco2(i,k) = zenfac(i)*pthco2
+ uo2 (i,k) = zenfac(i)*ptho2
+ uo3 (i,k) = ptho3
+ usul(i,k) = aermmr(i,k,idxSUL) * path
+ ubg(i,k) = aermmr(i,k,idxBG) * path
+ usslt(i,k) = aermmr(i,k,idxSSLT) * path
+ if (usslt(i,k) .lt. 0.0) then ! usslt is sometimes small and negative, will be fixed
+ usslt(i,k) = 0.0
+ end if
+ ucphil(i,k) = aermmr(i,k,idxOCPHI) * path
+ ucphob(i,k) = aermmr(i,k,idxOCPHO) * path
+ ucb(i,k) = ( aermmr(i,k,idxBCPHO) + aermmr(i,k,idxBCPHI) ) * path
+ uvolc(i,k) = aermmr(i,k,idxVOLC)
+ do ksz = 1, ndstsz
+ udst(ksz,i,k) = aermmr(i,k,idxDUSTfirst-1+ksz) * path
+ end do
+ end do
+!
+! Compute column absorber amounts for the clear sky computation:
+!
+ uth2o(i) = 0.0_r8
+ uto3(i) = 0.0_r8
+ utco2(i) = 0.0_r8
+ uto2(i) = 0.0_r8
+
+ do k=1,pver
+ uth2o(i) = uth2o(i) + uh2o(i,k)
+ uto3(i) = uto3(i) + uo3(i,k)
+ utco2(i) = utco2(i) + uco2(i,k)
+ uto2(i) = uto2(i) + uo2(i,k)
+ end do
+!
+! Set cloud properties for top (0) layer; so long as tauxcl is zero,
+! there is no cloud above top of model; the other cloud properties
+! are arbitrary:
+!
+ tauxcl(i,0) = 0._r8
+ wcl(i,0) = 0.999999_r8
+ gcl(i,0) = 0.85_r8
+ fcl(i,0) = 0.725_r8
+ tauxci(i,0) = 0._r8
+ wci(i,0) = 0.999999_r8
+ gci(i,0) = 0.85_r8
+ fci(i,0) = 0.725_r8
+!
+! Aerosol
+!
+ tauxar(i,0) = 0._r8
+ wa(i,0) = 0.925_r8
+ ga(i,0) = 0.850_r8
+ fa(i,0) = 0.7225_r8
+!
+! End do n=1,ndayc
+!
+ end do
+!
+! Begin spectral loop
+!
+ do ns=1,nspint
+!
+! Set index for cloud particle properties based on the wavelength,
+! according to A. Slingo (1989) equations 1-3:
+! Use index 1 (0.25 to 0.69 micrometers) for visible
+! Use index 2 (0.69 - 1.19 micrometers) for near-infrared
+! Use index 3 (1.19 to 2.38 micrometers) for near-infrared
+! Use index 4 (2.38 to 4.00 micrometers) for near-infrared
+!
+! Note that the minimum wavelength is encoded (with .001, .002, .003)
+! in order to specify the index appropriate for the near-infrared
+! cloud absorption properties
+!
+ if(wavmax(ns) <= 0.7_r8) then
+ indxsl = 1
+ else if(wavmin(ns) == 0.700_r8) then
+ indxsl = 2
+ else if(wavmin(ns) == 0.701_r8) then
+ indxsl = 3
+ else if(wavmin(ns) == 0.702_r8 .or. wavmin(ns) > 2.38_r8) then
+ indxsl = 4
+ end if
+!
+! Set cloud extinction optical depth, single scatter albedo,
+! asymmetry parameter, and forward scattered fraction:
+!
+ abarli = abarl(indxsl)
+ bbarli = bbarl(indxsl)
+ cbarli = cbarl(indxsl)
+ dbarli = dbarl(indxsl)
+ ebarli = ebarl(indxsl)
+ fbarli = fbarl(indxsl)
+!
+ abarii = abari(indxsl)
+ bbarii = bbari(indxsl)
+ cbarii = cbari(indxsl)
+ dbarii = dbari(indxsl)
+ ebarii = ebari(indxsl)
+ fbarii = fbari(indxsl)
+!
+! adjustfraction within spectral interval to allow for the possibility of
+! sub-divisions within a particular interval:
+!
+ psf(ns) = 1.0_r8
+ if(ph2o(ns)/=0._r8) psf(ns) = psf(ns)*ph2o(ns)
+ if(pco2(ns)/=0._r8) psf(ns) = psf(ns)*pco2(ns)
+ if(po2 (ns)/=0._r8) psf(ns) = psf(ns)*po2 (ns)
+
+ do n=1,ndayc
+ i=idayc(n)
+
+ frc_day(i) = 1.0_r8
+ do kaer = 1, naer_groups
+ aertau(i,ns,kaer) = 0.0
+ aerssa(i,ns,kaer) = 0.0
+ aerasm(i,ns,kaer) = 0.0
+ aerfwd(i,ns,kaer) = 0.0
+ end do
+
+ do k=1,pver
+!
+! liquid
+!
+ tmp1l = abarli + bbarli/rel(i,k)
+ tmp2l = 1._r8 - cbarli - dbarli*rel(i,k)
+ tmp3l = fbarli*rel(i,k)
+!
+! ice
+!
+ tmp1i = abarii + bbarii/rei(i,k)
+ tmp2i = 1._r8 - cbarii - dbarii*rei(i,k)
+ tmp3i = fbarii*rei(i,k)
+
+ if (cld(i,k) >= cldmin .and. cld(i,k) >= cldeps) then
+ tauxcl(i,k) = cliqwp(i,k)*tmp1l
+ tauxci(i,k) = cicewp(i,k)*tmp1i
+ else
+ tauxcl(i,k) = 0.0
+ tauxci(i,k) = 0.0
+ endif
+!
+! Do not let single scatter albedo be 1. Delta-eddington solution
+! for non-conservative case has different analytic form from solution
+! for conservative case, and raddedmx is written for non-conservative case.
+!
+ wcl(i,k) = min(tmp2l,.999999_r8)
+ gcl(i,k) = ebarli + tmp3l
+ fcl(i,k) = gcl(i,k)*gcl(i,k)
+!
+ wci(i,k) = min(tmp2i,.999999_r8)
+ gci(i,k) = ebarii + tmp3i
+ fci(i,k) = gci(i,k)*gci(i,k)
+!
+! Set aerosol properties
+! Conversion factor to adjust aerosol extinction (m2/g)
+!
+ rhtrunc = rh(i,k)
+ rhtrunc = min(rh(i,k),1._r8)
+! if(rhtrunc.lt.0._r8) call endrun ('RADCSWMX')
+ krh = min(floor( rhtrunc * nrh ) + 1, nrh - 1)
+ wrh = rhtrunc * nrh - krh
+
+ ! linear interpolation of optical properties between rh table points
+ ksuli = ksul(krh + 1, ns) * (wrh + 1) - ksul(krh, ns) * wrh
+ ksslti = ksslt(krh + 1, ns) * (wrh + 1) - ksslt(krh, ns) * wrh
+ kcphili = kcphil(krh + 1, ns) * (wrh + 1) - kcphil(krh, ns) * wrh
+ wsuli = wsul(krh + 1, ns) * (wrh + 1) - wsul(krh, ns) * wrh
+ wsslti = wsslt(krh + 1, ns) * (wrh + 1) - wsslt(krh, ns) * wrh
+ wcphili = wcphil(krh + 1, ns) * (wrh + 1) - wcphil(krh, ns) * wrh
+ gsuli = gsul(krh + 1, ns) * (wrh + 1) - gsul(krh, ns) * wrh
+ gsslti = gsslt(krh + 1, ns) * (wrh + 1) - gsslt(krh, ns) * wrh
+ gcphili = gcphil(krh + 1, ns) * (wrh + 1) - gcphil(krh, ns) * wrh
+
+ tau_sul = 1.e4 * ksuli * usul(i,k)
+ tau_sslt = 1.e4 * ksslti * usslt(i,k)
+ tau_cphil = 1.e4 * kcphili * ucphil(i,k)
+ tau_cphob = 1.e4 * kcphob(ns) * ucphob(i,k)
+ tau_cb = 1.e4 * kcb(ns) * ucb(i,k)
+ tau_volc = 1.e3 * kvolc(ns) * uvolc(i,k)
+ tau_dst(:) = 1.e4 * kdst(:,ns) * udst(:,i,k)
+ tau_bg = 1.e4 * kbg(ns) * ubg(i,k)
+
+ tau_w_sul = tau_sul * wsuli
+ tau_w_sslt = tau_sslt * wsslti
+ tau_w_cphil = tau_cphil * wcphili
+ tau_w_cphob = tau_cphob * wcphob(ns)
+ tau_w_cb = tau_cb * wcb(ns)
+ tau_w_volc = tau_volc * wvolc(ns)
+ tau_w_dst(:) = tau_dst(:) * wdst(:,ns)
+ tau_w_bg = tau_bg * wbg(ns)
+
+ tau_w_g_sul = tau_w_sul * gsuli
+ tau_w_g_sslt = tau_w_sslt * gsslti
+ tau_w_g_cphil = tau_w_cphil * gcphili
+ tau_w_g_cphob = tau_w_cphob * gcphob(ns)
+ tau_w_g_cb = tau_w_cb * gcb(ns)
+ tau_w_g_volc = tau_w_volc * gvolc(ns)
+ tau_w_g_dst(:) = tau_w_dst(:) * gdst(:,ns)
+ tau_w_g_bg = tau_w_bg * gbg(ns)
+
+ f_sul = gsuli * gsuli
+ f_sslt = gsslti * gsslti
+ f_cphil = gcphili * gcphili
+ f_cphob = gcphob(ns) * gcphob(ns)
+ f_cb = gcb(ns) * gcb(ns)
+ f_volc = gvolc(ns) * gvolc(ns)
+ f_dst(:) = gdst(:,ns) * gdst(:,ns)
+ f_bg = gbg(ns) * gbg(ns)
+
+ tau_w_f_sul = tau_w_sul * f_sul
+ tau_w_f_bg = tau_w_bg * f_bg
+ tau_w_f_sslt = tau_w_sslt * f_sslt
+ tau_w_f_cphil = tau_w_cphil * f_cphil
+ tau_w_f_cphob = tau_w_cphob * f_cphob
+ tau_w_f_cb = tau_w_cb * f_cb
+ tau_w_f_volc = tau_w_volc * f_volc
+ tau_w_f_dst(:) = tau_w_dst(:) * f_dst(:)
+!
+! mix dust aerosol size bins
+! w_dst_tot, g_dst_tot, w_dst_tot are currently not used anywhere
+! but calculate them anyway for future use
+!
+ tau_dst_tot = sum(tau_dst)
+ tau_w_dst_tot = sum(tau_w_dst)
+ tau_w_g_dst_tot = sum(tau_w_g_dst)
+ tau_w_f_dst_tot = sum(tau_w_f_dst)
+
+ if (tau_dst_tot .gt. 0.0) then
+ w_dst_tot = tau_w_dst_tot / tau_dst_tot
+ else
+ w_dst_tot = 0.0
+ endif
+
+ if (tau_w_dst_tot .gt. 0.0) then
+ g_dst_tot = tau_w_g_dst_tot / tau_w_dst_tot
+ f_dst_tot = tau_w_f_dst_tot / tau_w_dst_tot
+ else
+ g_dst_tot = 0.0
+ f_dst_tot = 0.0
+ endif
+!
+! mix aerosols
+!
+ tau_tot = tau_sul + tau_sslt &
+ + tau_cphil + tau_cphob + tau_cb + tau_dst_tot
+ tau_tot = tau_tot + tau_bg + tau_volc
+
+ tau_w_tot = tau_w_sul + tau_w_sslt &
+ + tau_w_cphil + tau_w_cphob + tau_w_cb + tau_w_dst_tot
+ tau_w_tot = tau_w_tot + tau_w_bg + tau_w_volc
+
+ tau_w_g_tot = tau_w_g_sul + tau_w_g_sslt &
+ + tau_w_g_cphil + tau_w_g_cphob + tau_w_g_cb + tau_w_g_dst_tot
+ tau_w_g_tot = tau_w_g_tot + tau_w_g_bg + tau_w_g_volc
+
+ tau_w_f_tot = tau_w_f_sul + tau_w_f_sslt &
+ + tau_w_f_cphil + tau_w_f_cphob + tau_w_f_cb + tau_w_f_dst_tot
+ tau_w_f_tot = tau_w_f_tot + tau_w_f_bg + tau_w_f_volc
+
+ if (tau_tot .gt. 0.0) then
+ w_tot = tau_w_tot / tau_tot
+ else
+ w_tot = 0.0
+ endif
+
+ if (tau_w_tot .gt. 0.0) then
+ g_tot = tau_w_g_tot / tau_w_tot
+ f_tot = tau_w_f_tot / tau_w_tot
+ else
+ g_tot = 0.0
+ f_tot = 0.0
+ endif
+
+ tauxar(i,k) = tau_tot
+ wa(i,k) = min(w_tot, 0.999999_r8)
+ if (g_tot.gt.1._r8) write(6,*) "g_tot > 1"
+ if (g_tot.lt.-1._r8) write(6,*) "g_tot < -1"
+! if (g_tot.gt.1._r8) call endrun ('RADCSWMX')
+! if (g_tot.lt.-1._r8) call endrun ('RADCSWMX')
+ ga(i,k) = g_tot
+ if (f_tot.gt.1._r8) write(6,*)"f_tot > 1"
+ if (f_tot.lt.0._r8) write(6,*)"f_tot < 0"
+! if (f_tot.gt.1._r8) call endrun ('RADCSWMX')
+! if (f_tot.lt.0._r8) call endrun ('RADCSWMX')
+ fa(i,k) = f_tot
+
+ aertau(i,ns,1) = aertau(i,ns,1) + tau_sul
+ aertau(i,ns,2) = aertau(i,ns,2) + tau_sslt
+ aertau(i,ns,3) = aertau(i,ns,3) + tau_cphil + tau_cphob + tau_cb
+ aertau(i,ns,4) = aertau(i,ns,4) + tau_dst_tot
+ aertau(i,ns,5) = aertau(i,ns,5) + tau_bg
+ aertau(i,ns,6) = aertau(i,ns,6) + tau_volc
+ aertau(i,ns,7) = aertau(i,ns,7) + tau_tot
+
+ aerssa(i,ns,1) = aerssa(i,ns,1) + tau_w_sul
+ aerssa(i,ns,2) = aerssa(i,ns,2) + tau_w_sslt
+ aerssa(i,ns,3) = aerssa(i,ns,3) + tau_w_cphil + tau_w_cphob + tau_w_cb
+ aerssa(i,ns,4) = aerssa(i,ns,4) + tau_w_dst_tot
+ aerssa(i,ns,5) = aerssa(i,ns,5) + tau_w_bg
+ aerssa(i,ns,6) = aerssa(i,ns,6) + tau_w_volc
+ aerssa(i,ns,7) = aerssa(i,ns,7) + tau_w_tot
+
+ aerasm(i,ns,1) = aerasm(i,ns,1) + tau_w_g_sul
+ aerasm(i,ns,2) = aerasm(i,ns,2) + tau_w_g_sslt
+ aerasm(i,ns,3) = aerasm(i,ns,3) + tau_w_g_cphil + tau_w_g_cphob + tau_w_g_cb
+ aerasm(i,ns,4) = aerasm(i,ns,4) + tau_w_g_dst_tot
+ aerasm(i,ns,5) = aerasm(i,ns,5) + tau_w_g_bg
+ aerasm(i,ns,6) = aerasm(i,ns,6) + tau_w_g_volc
+ aerasm(i,ns,7) = aerasm(i,ns,7) + tau_w_g_tot
+
+ aerfwd(i,ns,1) = aerfwd(i,ns,1) + tau_w_f_sul
+ aerfwd(i,ns,2) = aerfwd(i,ns,2) + tau_w_f_sslt
+ aerfwd(i,ns,3) = aerfwd(i,ns,3) + tau_w_f_cphil + tau_w_f_cphob + tau_w_f_cb
+ aerfwd(i,ns,4) = aerfwd(i,ns,4) + tau_w_f_dst_tot
+ aerfwd(i,ns,5) = aerfwd(i,ns,5) + tau_w_f_bg
+ aerfwd(i,ns,6) = aerfwd(i,ns,6) + tau_w_f_volc
+ aerfwd(i,ns,7) = aerfwd(i,ns,7) + tau_w_f_tot
+
+!
+! End do k=1,pver
+!
+ end do
+
+ ! normalize aerosol optical diagnostic fields
+ do kaer = 1, naer_groups
+
+ if (aerssa(i,ns,kaer) .gt. 0.0) then ! aerssa currently holds product of tau and ssa
+ aerasm(i,ns,kaer) = aerasm(i,ns,kaer) / aerssa(i,ns,kaer)
+ aerfwd(i,ns,kaer) = aerfwd(i,ns,kaer) / aerssa(i,ns,kaer)
+ else
+ aerasm(i,ns,kaer) = 0.0_r8
+ aerfwd(i,ns,kaer) = 0.0_r8
+ end if
+
+ if (aertau(i,ns,kaer) .gt. 0.0) then
+ aerssa(i,ns,kaer) = aerssa(i,ns,kaer) / aertau(i,ns,kaer)
+ else
+ aerssa(i,ns,kaer) = 0.0_r8
+ end if
+
+ end do
+
+
+!
+! End do n=1,ndayc
+!
+ end do
+
+!
+! Set reflectivities for surface based on mid-point wavelength
+!
+ wavmid(ns) = 0.5_r8*(wavmin(ns) + wavmax(ns))
+!
+! Wavelength less than 0.7 micro-meter
+!
+ if (wavmid(ns) < 0.7_r8 ) then
+ do n=1,ndayc
+ i=idayc(n)
+ albdir(i,ns) = asdir(i)
+ albdif(i,ns) = asdif(i)
+ end do
+!
+! Wavelength greater than 0.7 micro-meter
+!
+ else
+ do n=1,ndayc
+ i=idayc(n)
+ albdir(i,ns) = aldir(i)
+ albdif(i,ns) = aldif(i)
+ end do
+ end if
+ trayoslp = raytau(ns)/sslp
+!
+! Layer input properties now completely specified; compute the
+! delta-Eddington solution reflectivities and transmissivities
+! for each layer
+!
+ call raddedmx(pver, pverp, pcols, coszrs ,ndayc ,idayc , &
+ abh2o(ns),abo3(ns) ,abco2(ns),abo2(ns) , &
+ uh2o ,uo3 ,uco2 ,uo2 , &
+ trayoslp ,pflx ,ns , &
+ tauxcl ,wcl ,gcl ,fcl , &
+ tauxci ,wci ,gci ,fci , &
+ tauxar ,wa ,ga ,fa , &
+ rdir ,rdif ,tdir ,tdif ,explay , &
+ rdirc ,rdifc ,tdirc ,tdifc ,explayc )
+!
+! End spectral loop
+!
+ end do
+!
+!----------------------------------------------------------------------
+!
+! Solution for max/random cloud overlap.
+!
+! Steps:
+! (1. delta-Eddington solution for each layer (called above)
+!
+! (2. The adding method is used to
+! compute the reflectivity and transmissivity to direct and diffuse
+! radiation from the top and bottom of the atmosphere for each
+! cloud configuration. This calculation is based upon the
+! max-random overlap assumption.
+!
+! (3. to solve for the fluxes, combine the
+! bulk properties of the atmosphere above/below the region.
+!
+! Index calculations for steps 2-3 are performed outside spectral
+! loop to avoid redundant calculations. Index calculations (with
+! application of areamin & nconfgmax conditions) are performed
+! first to identify the minimum subset of terms for the configurations
+! satisfying the areamin & nconfgmax conditions. This minimum set is
+! used to identify the corresponding minimum subset of terms in
+! steps 2 and 3.
+!
+
+ do n=1,ndayc
+ i=idayc(n)
+
+!----------------------------------------------------------------------
+! INDEX CALCULATIONS FOR MAX OVERLAP
+!
+! The column is divided into sets of adjacent layers, called regions,
+! in which the clouds are maximally overlapped. The clouds are
+! randomly overlapped between different regions. The number of
+! regions in a column is set by nmxrgn, and the range of pressures
+! included in each region is set by pmxrgn.
+!
+! The following calculations determine the number of unique cloud
+! configurations (assuming maximum overlap), called "streams",
+! within each region. Each stream consists of a vector of binary
+! clouds (either 0 or 100% cloud cover). Over the depth of the region,
+! each stream requires a separate calculation of radiative properties. These
+! properties are generated using the adding method from
+! the radiative properties for each layer calculated by raddedmx.
+!
+! The upward and downward-propagating streams are treated
+! separately.
+!
+! We will refer to a particular configuration of binary clouds
+! within a single max-overlapped region as a "stream". We will
+! refer to a particular arrangement of binary clouds over the entire column
+! as a "configuration".
+!
+! This section of the code generates the following information:
+! (1. nrgn : the true number of max-overlap regions (need not = nmxrgn)
+! (2. nstr : the number of streams in a region (>=1)
+! (3. cstr : flags for presence of clouds at each layer in each stream
+! (4. wstr : the fractional horizontal area of a grid box covered
+! by each stream
+! (5. kx1,2 : level indices for top/bottom of each region
+!
+! The max-overlap calculation proceeds in 3 stages:
+! (1. compute layer radiative properties in raddedmx.
+! (2. combine these properties between layers
+! (3. combine properties to compute fluxes at each interface.
+!
+! Most of the indexing information calculated here is used in steps 2-3
+! after the call to raddedmx.
+!
+! Initialize indices for layers to be max-overlapped
+!
+! Loop to handle fix in totwgt=0. For original overlap config
+! from npasses = 0.
+!
+ npasses = 0
+ do
+ do irgn = 0, nmxrgn(i)
+ kx2(irgn) = 0
+ end do
+ mrgn = 0
+!
+! Outermost loop over regions (sets of adjacent layers) to be max overlapped
+!
+ do irgn = 1, nmxrgn(i)
+!
+! Calculate min/max layer indices inside region.
+!
+ region_found = .false.
+ if (kx2(irgn-1) < pver) then
+ k1 = kx2(irgn-1)+1
+ kx1(irgn) = k1
+ kx2(irgn) = k1-1
+ do k2 = pver, k1, -1
+ if (pmid(i,k2) <= pmxrgn(i,irgn)) then
+ kx2(irgn) = k2
+ mrgn = mrgn+1
+ region_found = .true.
+ exit
+ end if
+ end do
+ else
+ exit
+ endif
+
+ if (region_found) then
+!
+! Sort cloud areas and corresponding level indices.
+!
+ nxs = 0
+ if (cldeps > 0) then
+ do k = k1,k2
+ if (cld(i,k) >= cldmin .and. cld(i,k) >= cldeps) then
+ nxs = nxs+1
+ ksort(nxs) = k
+!
+! We need indices for clouds in order of largest to smallest, so
+! sort 1-cld in ascending order
+!
+ asort(nxs) = 1.0_r8-(floor(cld(i,k)/cldeps)*cldeps)
+ end if
+ end do
+ else
+ do k = k1,k2
+ if (cld(i,k) >= cldmin) then
+ nxs = nxs+1
+ ksort(nxs) = k
+!
+! We need indices for clouds in order of largest to smallest, so
+! sort 1-cld in ascending order
+!
+ asort(nxs) = 1.0_r8-cld(i,k)
+ end if
+ end do
+ endif
+!
+! If nxs eq 1, no need to sort.
+! If nxs eq 2, sort by swapping if necessary
+! If nxs ge 3, sort using local sort routine
+!
+ if (nxs == 2) then
+ if (asort(2) < asort(1)) then
+ ktmp = ksort(1)
+ ksort(1) = ksort(2)
+ ksort(2) = ktmp
+
+ atmp = asort(1)
+ asort(1) = asort(2)
+ asort(2) = atmp
+ endif
+ else if (nxs >= 3) then
+ call sortarray(nxs,asort,ksort)
+ endif
+!
+! Construct wstr, cstr, nstr for this region
+!
+ cstr(k1:k2,1:nxs+1) = 0
+ mstr = 1
+ cld0 = 0.0_r8
+ do l = 1, nxs
+ if (asort(l) /= cld0) then
+ wstr(mstr,mrgn) = asort(l) - cld0
+ cld0 = asort(l)
+ mstr = mstr + 1
+ endif
+ cstr(ksort(l),mstr:nxs+1) = 1
+ end do
+ nstr(mrgn) = mstr
+ wstr(mstr,mrgn) = 1.0_r8 - cld0
+!
+! End test of region_found = true
+!
+ endif
+!
+! End loop over regions irgn for max-overlap
+!
+ end do
+ nrgn = mrgn
+!
+! Finish construction of cstr for additional top layer
+!
+ cstr(0,1:nstr(1)) = 0
+!
+! INDEX COMPUTATIONS FOR STEP 2-3
+! This section of the code generates the following information:
+! (1. totwgt step 3 total frac. area of configurations satisfying
+! areamin & nconfgmax criteria
+! (2. wgtv step 3 frac. area of configurations
+! (3. ccon step 2 binary flag for clouds in each configuration
+! (4. nconfig steps 2-3 number of configurations
+! (5. nuniqu/d step 2 Number of unique cloud configurations for
+! up/downwelling rad. between surface/TOA
+! and level k
+! (6. istrtu/d step 2 Indices into iconu/d
+! (7. iconu/d step 2 Cloud configurations which are identical
+! for up/downwelling rad. between surface/TOA
+! and level k
+!
+! Number of configurations (all permutations of streams in each region)
+!
+ nconfigm = product(nstr(1: nrgn))
+!
+! Construction of totwgt, wgtv, ccon, nconfig
+!
+ istr(1: nrgn) = 1
+ nconfig = 0
+ totwgt = 0.0_r8
+ new_term = .true.
+ do iconfig = 1, nconfigm
+ xwgt = 1.0_r8
+ do mrgn = 1, nrgn
+ xwgt = xwgt * wstr(istr(mrgn),mrgn)
+ end do
+ if (xwgt >= areamin) then
+ nconfig = nconfig + 1
+ if (nconfig <= nconfgmax) then
+ j = nconfig
+ ptrc(nconfig) = nconfig
+ else
+ nconfig = nconfgmax
+ if (new_term) then
+ j = findvalue(1,nconfig,wgtv,ptrc)
+ endif
+ if (wgtv(j) < xwgt) then
+ totwgt = totwgt - wgtv(j)
+ new_term = .true.
+ else
+ new_term = .false.
+ endif
+ endif
+ if (new_term) then
+ wgtv(j) = xwgt
+ totwgt = totwgt + xwgt
+ do mrgn = 1, nrgn
+ ccon(kx1(mrgn):kx2(mrgn),j) = cstr(kx1(mrgn):kx2(mrgn),istr(mrgn))
+ end do
+ endif
+ endif
+
+ mrgn = nrgn
+ istr(mrgn) = istr(mrgn) + 1
+ do while (istr(mrgn) > nstr(mrgn) .and. mrgn > 1)
+ istr(mrgn) = 1
+ mrgn = mrgn - 1
+ istr(mrgn) = istr(mrgn) + 1
+ end do
+!
+! End do iconfig = 1, nconfigm
+!
+ end do
+!
+! If totwgt = 0 implement maximum overlap and make another pass
+! if totwgt = 0 on this second pass then terminate.
+!
+ if (totwgt > 0.) then
+ exit
+ else
+ npasses = npasses + 1
+ if (npasses >= 2 ) then
+ write(6,*)'RADCSWMX: Maximum overlap of column ','failed'
+ call endrun
+ endif
+ nmxrgn(i)=1
+ pmxrgn(i,1)=1.0e30
+ end if
+!
+! End npasses = 0, do
+!
+ end do
+!
+!
+! Finish construction of ccon
+!
+ ccon(0,:) = 0
+ ccon(pverp,:) = 0
+!
+! Construction of nuniqu/d, istrtu/d, iconu/d using binary tree
+!
+ nuniqd(0) = 1
+ nuniqu(pverp) = 1
+
+ istrtd(0,1) = 1
+ istrtu(pverp,1) = 1
+
+ do j = 1, nconfig
+ icond(0,j)=j
+ iconu(pverp,j)=j
+ end do
+
+ istrtd(0,2) = nconfig+1
+ istrtu(pverp,2) = nconfig+1
+
+ do k = 1, pverp
+ km1 = k-1
+ nuniq = 0
+ istrtd(k,1) = 1
+ do l0 = 1, nuniqd(km1)
+ is0 = istrtd(km1,l0)
+ is1 = istrtd(km1,l0+1)-1
+ n0 = 0
+ n1 = 0
+ do isn = is0, is1
+ j = icond(km1,isn)
+ if (ccon(k,j) == 0) then
+ n0 = n0 + 1
+ ptr0(n0) = j
+ endif
+ if (ccon(k,j) == 1) then
+ n1 = n1 + 1
+ ptr1(n1) = j
+ endif
+ end do
+ if (n0 > 0) then
+ nuniq = nuniq + 1
+ istrtd(k,nuniq+1) = istrtd(k,nuniq)+n0
+ icond(k,istrtd(k,nuniq):istrtd(k,nuniq+1)-1) = ptr0(1:n0)
+ endif
+ if (n1 > 0) then
+ nuniq = nuniq + 1
+ istrtd(k,nuniq+1) = istrtd(k,nuniq)+n1
+ icond(k,istrtd(k,nuniq):istrtd(k,nuniq+1)-1) = ptr1(1:n1)
+ endif
+ end do
+ nuniqd(k) = nuniq
+ end do
+
+ do k = pver, 0, -1
+ kp1 = k+1
+ nuniq = 0
+ istrtu(k,1) = 1
+ do l0 = 1, nuniqu(kp1)
+ is0 = istrtu(kp1,l0)
+ is1 = istrtu(kp1,l0+1)-1
+ n0 = 0
+ n1 = 0
+ do isn = is0, is1
+ j = iconu(kp1,isn)
+ if (ccon(k,j) == 0) then
+ n0 = n0 + 1
+ ptr0(n0) = j
+ endif
+ if (ccon(k,j) == 1) then
+ n1 = n1 + 1
+ ptr1(n1) = j
+ endif
+ end do
+ if (n0 > 0) then
+ nuniq = nuniq + 1
+ istrtu(k,nuniq+1) = istrtu(k,nuniq)+n0
+ iconu(k,istrtu(k,nuniq):istrtu(k,nuniq+1)-1) = ptr0(1:n0)
+ endif
+ if (n1 > 0) then
+ nuniq = nuniq + 1
+ istrtu(k,nuniq+1) = istrtu(k,nuniq)+n1
+ iconu(k,istrtu(k,nuniq):istrtu(k,nuniq+1)-1) = ptr1(1:n1)
+ endif
+ end do
+ nuniqu(k) = nuniq
+ end do
+!
+!----------------------------------------------------------------------
+! End of index calculations
+!----------------------------------------------------------------------
+
+
+!----------------------------------------------------------------------
+! Start of flux calculations
+!----------------------------------------------------------------------
+!
+! Initialize spectrally integrated totals:
+!
+ do k=0,pver
+ totfld(k) = 0.0_r8
+ fswup (k) = 0.0_r8
+ fswdn (k) = 0.0_r8
+ fswupc (k) = 0.0_r8
+ fswdnc (k) = 0.0_r8
+ end do
+
+ sfltot = 0.0_r8
+ fswup (pverp) = 0.0_r8
+ fswdn (pverp) = 0.0_r8
+ fswupc (pverp) = 0.0_r8
+ fswdnc (pverp) = 0.0_r8
+!
+! Start spectral interval
+!
+ do ns = 1,nspint
+ wgtint = nirwgt(ns)
+!----------------------------------------------------------------------
+! STEP 2
+!
+!
+! Apply adding method to solve for radiative properties
+!
+! First initialize the bulk properties at TOA
+!
+ rdndif(0,1:nconfig) = 0.0_r8
+ exptdn(0,1:nconfig) = 1.0_r8
+ tdntot(0,1:nconfig) = 1.0_r8
+!
+! Solve for properties involving downward propagation of radiation.
+! The bulk properties are:
+!
+! (1. exptdn Sol. beam dwn. trans from layers above
+! (2. rdndif Ref to dif rad for layers above
+! (3. tdntot Total trans for layers above
+!
+ do k = 1, pverp
+ km1 = k - 1
+ do l0 = 1, nuniqd(km1)
+ is0 = istrtd(km1,l0)
+ is1 = istrtd(km1,l0+1)-1
+
+ j = icond(km1,is0)
+
+ xexpt = exptdn(km1,j)
+ xrdnd = rdndif(km1,j)
+ tdnmexp = tdntot(km1,j) - xexpt
+
+ if (ccon(km1,j) == 1) then
+!
+! If cloud in layer, use cloudy layer radiative properties
+!
+ ytdnd = tdif(ns,i,km1)
+ yrdnd = rdif(ns,i,km1)
+
+ rdenom = 1._r8/(1._r8-yrdnd*xrdnd)
+ rdirexp = rdir(ns,i,km1)*xexpt
+
+ zexpt = xexpt * explay(ns,i,km1)
+ zrdnd = yrdnd + xrdnd*(ytdnd**2)*rdenom
+ ztdnt = xexpt*tdir(ns,i,km1) + ytdnd*(tdnmexp + xrdnd*rdirexp)*rdenom
+ else
+!
+! If clear layer, use clear-sky layer radiative properties
+!
+ ytdnd = tdifc(ns,i,km1)
+ yrdnd = rdifc(ns,i,km1)
+
+ rdenom = 1._r8/(1._r8-yrdnd*xrdnd)
+ rdirexp = rdirc(ns,i,km1)*xexpt
+
+ zexpt = xexpt * explayc(ns,i,km1)
+ zrdnd = yrdnd + xrdnd*(ytdnd**2)*rdenom
+ ztdnt = xexpt*tdirc(ns,i,km1) + ytdnd* &
+ (tdnmexp + xrdnd*rdirexp)*rdenom
+ endif
+
+!
+! If 2 or more configurations share identical properties at a given level k,
+! the properties (at level k) are computed once and copied to
+! all the configurations for efficiency.
+!
+ do isn = is0, is1
+ j = icond(km1,isn)
+ exptdn(k,j) = zexpt
+ rdndif(k,j) = zrdnd
+ tdntot(k,j) = ztdnt
+ end do
+!
+! end do l0 = 1, nuniqd(k)
+!
+ end do
+!
+! end do k = 1, pverp
+!
+ end do
+!
+! Solve for properties involving upward propagation of radiation.
+! The bulk properties are:
+!
+! (1. rupdif Ref to dif rad for layers below
+! (2. rupdir Ref to dir rad for layers below
+!
+! Specify surface boundary conditions (surface albedos)
+!
+ rupdir(pverp,1:nconfig) = albdir(i,ns)
+ rupdif(pverp,1:nconfig) = albdif(i,ns)
+
+ do k = pver, 0, -1
+ do l0 = 1, nuniqu(k)
+ is0 = istrtu(k,l0)
+ is1 = istrtu(k,l0+1)-1
+
+ j = iconu(k,is0)
+
+ xrupd = rupdif(k+1,j)
+ xrups = rupdir(k+1,j)
+
+ if (ccon(k,j) == 1) then
+!
+! If cloud in layer, use cloudy layer radiative properties
+!
+ yexpt = explay(ns,i,k)
+ yrupd = rdif(ns,i,k)
+ ytupd = tdif(ns,i,k)
+
+ rdenom = 1._r8/( 1._r8 - yrupd*xrupd)
+ tdnmexp = (tdir(ns,i,k)-yexpt)
+ rdirexp = xrups*yexpt
+
+ zrupd = yrupd + xrupd*(ytupd**2)*rdenom
+ zrups = rdir(ns,i,k) + ytupd*(rdirexp + xrupd*tdnmexp)*rdenom
+ else
+!
+! If clear layer, use clear-sky layer radiative properties
+!
+ yexpt = explayc(ns,i,k)
+ yrupd = rdifc(ns,i,k)
+ ytupd = tdifc(ns,i,k)
+
+ rdenom = 1._r8/( 1._r8 - yrupd*xrupd)
+ tdnmexp = (tdirc(ns,i,k)-yexpt)
+ rdirexp = xrups*yexpt
+
+ zrupd = yrupd + xrupd*(ytupd**2)*rdenom
+ zrups = rdirc(ns,i,k) + ytupd*(rdirexp + xrupd*tdnmexp)*rdenom
+ endif
+
+!
+! If 2 or more configurations share identical properties at a given level k,
+! the properties (at level k) are computed once and copied to
+! all the configurations for efficiency.
+!
+ do isn = is0, is1
+ j = iconu(k,isn)
+ rupdif(k,j) = zrupd
+ rupdir(k,j) = zrups
+ end do
+!
+! end do l0 = 1, nuniqu(k)
+!
+ end do
+!
+! end do k = pver,0,-1
+!
+ end do
+!
+!----------------------------------------------------------------------
+!
+! STEP 3
+!
+! Compute up and down fluxes for each interface k. This requires
+! adding up the contributions from all possible permutations
+! of streams in all max-overlap regions, weighted by the
+! product of the fractional areas of the streams in each region
+! (the random overlap assumption). The adding principle has been
+! used in step 2 to combine the bulk radiative properties
+! above and below the interface.
+!
+ do k = 0,pverp
+!
+! Initialize the fluxes
+!
+ fluxup(k)=0.0_r8
+ fluxdn(k)=0.0_r8
+
+ do iconfig = 1, nconfig
+ xwgt = wgtv(iconfig)
+ xexpt = exptdn(k,iconfig)
+ xtdnt = tdntot(k,iconfig)
+ xrdnd = rdndif(k,iconfig)
+ xrupd = rupdif(k,iconfig)
+ xrups = rupdir(k,iconfig)
+!
+! Flux computation
+!
+ rdenom = 1._r8/(1._r8 - xrdnd * xrupd)
+
+ fluxup(k) = fluxup(k) + xwgt * &
+ ((xexpt * xrups + (xtdnt - xexpt) * xrupd) * rdenom)
+ fluxdn(k) = fluxdn(k) + xwgt * &
+ (xexpt + (xtdnt - xexpt + xexpt * xrups * xrdnd) * rdenom)
+!
+! End do iconfig = 1, nconfig
+!
+ end do
+!
+! Normalize by total area covered by cloud configurations included
+! in solution
+!
+ fluxup(k)=fluxup(k) / totwgt
+ fluxdn(k)=fluxdn(k) / totwgt
+!
+! End do k = 0,pverp
+!
+ end do
+!
+! Initialize the direct-beam flux at surface
+!
+ wexptdn = 0.0_r8
+
+ do iconfig = 1, nconfig
+ wexptdn = wexptdn + wgtv(iconfig) * exptdn(pverp,iconfig)
+ end do
+
+ wexptdn = wexptdn / totwgt
+!
+! Monochromatic computation completed; accumulate in totals
+!
+ solflx = solin(i)*frcsol(ns)*psf(ns)
+ fsnt(i) = fsnt(i) + solflx*(fluxdn(1) - fluxup(1))
+ fsntoa(i)= fsntoa(i) + solflx*(fluxdn(0) - fluxup(0))
+ fsns(i) = fsns(i) + solflx*(fluxdn(pverp)-fluxup(pverp))
+ sfltot = sfltot + solflx
+ fswup(0) = fswup(0) + solflx*fluxup(0)
+ fswdn(0) = fswdn(0) + solflx*fluxdn(0)
+!
+! Down spectral fluxes need to be in mks; thus the .001 conversion factors
+!
+ if (wavmid(ns) < 0.7_r8) then
+ sols(i) = sols(i) + wexptdn*solflx*0.001_r8
+ solsd(i) = solsd(i)+(fluxdn(pverp)-wexptdn)*solflx*0.001_r8
+ else
+ soll(i) = soll(i) + wexptdn*solflx*0.001_r8
+ solld(i) = solld(i)+(fluxdn(pverp)-wexptdn)*solflx*0.001_r8
+ fsnrtoaq(i) = fsnrtoaq(i) + solflx*(fluxdn(0) - fluxup(0))
+ end if
+ fsnirtoa(i) = fsnirtoa(i) + wgtint*solflx*(fluxdn(0) - fluxup(0))
+
+ do k=0,pver
+!
+! Compute flux divergence in each layer using the interface up and down
+! fluxes:
+!
+ kp1 = k+1
+ flxdiv = (fluxdn(k ) - fluxdn(kp1)) + (fluxup(kp1) - fluxup(k ))
+ totfld(k) = totfld(k) + solflx*flxdiv
+ fswdn(kp1) = fswdn(kp1) + solflx*fluxdn(kp1)
+ fswup(kp1) = fswup(kp1) + solflx*fluxup(kp1)
+ end do
+!
+! Perform clear-sky calculation
+!
+ exptdnc(0) = 1.0_r8
+ rdndifc(0) = 0.0_r8
+ tdntotc(0) = 1.0_r8
+ rupdirc(pverp) = albdir(i,ns)
+ rupdifc(pverp) = albdif(i,ns)
+
+ do k = 1, pverp
+ km1 = k - 1
+ xexpt = exptdnc(km1)
+ xrdnd = rdndifc(km1)
+ yrdnd = rdifc(ns,i,km1)
+ ytdnd = tdifc(ns,i,km1)
+
+ exptdnc(k) = xexpt*explayc(ns,i,km1)
+
+ rdenom = 1._r8/(1._r8 - yrdnd*xrdnd)
+ rdirexp = rdirc(ns,i,km1)*xexpt
+ tdnmexp = tdntotc(km1) - xexpt
+
+ tdntotc(k) = xexpt*tdirc(ns,i,km1) + ytdnd*(tdnmexp + xrdnd*rdirexp)* &
+ rdenom
+ rdndifc(k) = yrdnd + xrdnd*(ytdnd**2)*rdenom
+ end do
+
+ do k=pver,0,-1
+ xrupd = rupdifc(k+1)
+ yexpt = explayc(ns,i,k)
+ yrupd = rdifc(ns,i,k)
+ ytupd = tdifc(ns,i,k)
+
+ rdenom = 1._r8/( 1._r8 - yrupd*xrupd)
+
+ rupdirc(k) = rdirc(ns,i,k) + ytupd*(rupdirc(k+1)*yexpt + &
+ xrupd*(tdirc(ns,i,k)-yexpt))*rdenom
+ rupdifc(k) = yrupd + xrupd*ytupd**2*rdenom
+ end do
+
+ do k=0,1
+ rdenom = 1._r8/(1._r8 - rdndifc(k)*rupdifc(k))
+ fluxup(k) = (exptdnc(k)*rupdirc(k) + (tdntotc(k)-exptdnc(k))*rupdifc(k))* &
+ rdenom
+ fluxdn(k) = exptdnc(k) + &
+ (tdntotc(k) - exptdnc(k) + exptdnc(k)*rupdirc(k)*rdndifc(k))* &
+ rdenom
+ fswupc(k) = fswupc(k) + solflx*fluxup(k)
+ fswdnc(k) = fswdnc(k) + solflx*fluxdn(k)
+ end do
+! k = pverp
+ do k=2,pverp
+ rdenom = 1._r8/(1._r8 - rdndifc(k)*rupdifc(k))
+ fluxup(k) = (exptdnc(k)*rupdirc(k) + (tdntotc(k)-exptdnc(k))*rupdifc(k))* &
+ rdenom
+ fluxdn(k) = exptdnc(k) + (tdntotc(k) - exptdnc(k) + &
+ exptdnc(k)*rupdirc(k)*rdndifc(k))*rdenom
+ fswupc(k) = fswupc(k) + solflx*fluxup(k)
+ fswdnc(k) = fswdnc(k) + solflx*fluxdn(k)
+ end do
+
+ fsntc(i) = fsntc(i)+solflx*(fluxdn(1)-fluxup(1))
+ fsntoac(i) = fsntoac(i)+solflx*(fluxdn(0)-fluxup(0))
+ fsnsc(i) = fsnsc(i)+solflx*(fluxdn(pverp)-fluxup(pverp))
+ fsdsc(i) = fsdsc(i)+solflx*(fluxdn(pverp))
+ fsnrtoac(i) = fsnrtoac(i)+wgtint*solflx*(fluxdn(0)-fluxup(0))
+!
+! End of clear sky calculation
+!
+
+!
+! End of spectral interval loop
+!
+ end do
+!
+! Compute solar heating rate (J/kg/s)
+!
+ do k=1,pver
+ qrs(i,k) = -1.E-4*gravit*totfld(k)/(pint(i,k) - pint(i,k+1))
+ end do
+
+! Added downward/upward total and clear sky fluxes
+
+ do k=1,pverp
+ fsup(i,k) = fswup(k)
+ fsupc(i,k) = fswupc(k)
+ fsdn(i,k) = fswdn(k)
+ fsdnc(i,k) = fswdnc(k)
+ end do
+!
+! Set the downwelling flux at the surface
+!
+ fsds(i) = fswdn(pverp)
+!
+! End do n=1,ndayc
+!
+ end do
+
+! write (6, '(a, x, i3)') 'radcswmx : exiting, chunk identifier', lchnk
+
+ return
+end subroutine radcswmx
+
+subroutine raddedmx(pver, pverp, pcols, coszrs ,ndayc ,idayc ,abh2o , &
+ abo3 ,abco2 ,abo2 ,uh2o ,uo3 , &
+ uco2 ,uo2 ,trayoslp,pflx ,ns , &
+ tauxcl ,wcl ,gcl ,fcl ,tauxci , &
+ wci ,gci ,fci ,tauxar ,wa , &
+ ga ,fa ,rdir ,rdif ,tdir , &
+ tdif ,explay ,rdirc ,rdifc ,tdirc , &
+ tdifc ,explayc )
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Computes layer reflectivities and transmissivities, from the top down
+! to the surface using the delta-Eddington solutions for each layer
+!
+! Method:
+! For more details , see Briegleb, Bruce P., 1992: Delta-Eddington
+! Approximation for Solar Radiation in the NCAR Community Climate Model,
+! Journal of Geophysical Research, Vol 97, D7, pp7603-7612).
+!
+! Modified for maximum/random cloud overlap by Bill Collins and John
+! Truesdale
+!
+! Author: Bill Collins
+!
+!-----------------------------------------------------------------------
+! use shr_kind_mod, only: r8 => shr_kind_r8
+! use ppgrid
+
+ implicit none
+
+ integer nspint ! Num of spctrl intervals across solar spectrum
+
+ parameter ( nspint = 19 )
+!
+! Minimum total transmission below which no layer computation are done:
+!
+ real(r8) trmin ! Minimum total transmission allowed
+ real(r8) wray ! Rayleigh single scatter albedo
+ real(r8) gray ! Rayleigh asymetry parameter
+ real(r8) fray ! Rayleigh forward scattered fraction
+
+ parameter (trmin = 1.e-3)
+ parameter (wray = 0.999999)
+ parameter (gray = 0.0)
+ parameter (fray = 0.1)
+!
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+ integer, intent(in) :: pver, pverp, pcols
+ real(r8), intent(in) :: coszrs(pcols) ! Cosine zenith angle
+ real(r8), intent(in) :: trayoslp ! Tray/sslp
+ real(r8), intent(in) :: pflx(pcols,0:pverp) ! Interface pressure
+ real(r8), intent(in) :: abh2o ! Absorption coefficiant for h2o
+ real(r8), intent(in) :: abo3 ! Absorption coefficiant for o3
+ real(r8), intent(in) :: abco2 ! Absorption coefficiant for co2
+ real(r8), intent(in) :: abo2 ! Absorption coefficiant for o2
+ real(r8), intent(in) :: uh2o(pcols,0:pver) ! Layer absorber amount of h2o
+ real(r8), intent(in) :: uo3(pcols,0:pver) ! Layer absorber amount of o3
+ real(r8), intent(in) :: uco2(pcols,0:pver) ! Layer absorber amount of co2
+ real(r8), intent(in) :: uo2(pcols,0:pver) ! Layer absorber amount of o2
+ real(r8), intent(in) :: tauxcl(pcols,0:pver) ! Cloud extinction optical depth (liquid)
+ real(r8), intent(in) :: wcl(pcols,0:pver) ! Cloud single scattering albedo (liquid)
+ real(r8), intent(in) :: gcl(pcols,0:pver) ! Cloud asymmetry parameter (liquid)
+ real(r8), intent(in) :: fcl(pcols,0:pver) ! Cloud forward scattered fraction (liquid)
+ real(r8), intent(in) :: tauxci(pcols,0:pver) ! Cloud extinction optical depth (ice)
+ real(r8), intent(in) :: wci(pcols,0:pver) ! Cloud single scattering albedo (ice)
+ real(r8), intent(in) :: gci(pcols,0:pver) ! Cloud asymmetry parameter (ice)
+ real(r8), intent(in) :: fci(pcols,0:pver) ! Cloud forward scattered fraction (ice)
+ real(r8), intent(in) :: tauxar(pcols,0:pver) ! Aerosol extinction optical depth
+ real(r8), intent(in) :: wa(pcols,0:pver) ! Aerosol single scattering albedo
+ real(r8), intent(in) :: ga(pcols,0:pver) ! Aerosol asymmetry parameter
+ real(r8), intent(in) :: fa(pcols,0:pver) ! Aerosol forward scattered fraction
+
+ integer, intent(in) :: ndayc ! Number of daylight columns
+ integer, intent(in) :: idayc(pcols) ! Daylight column indices
+ integer, intent(in) :: ns ! Index of spectral interval
+!
+! Input/Output arguments
+!
+! Following variables are defined for each layer; 0 refers to extra
+! layer above top of model:
+!
+ real(r8), intent(inout) :: rdir(nspint,pcols,0:pver) ! Layer reflectivity to direct rad
+ real(r8), intent(inout) :: rdif(nspint,pcols,0:pver) ! Layer reflectivity to diffuse rad
+ real(r8), intent(inout) :: tdir(nspint,pcols,0:pver) ! Layer transmission to direct rad
+ real(r8), intent(inout) :: tdif(nspint,pcols,0:pver) ! Layer transmission to diffuse rad
+ real(r8), intent(inout) :: explay(nspint,pcols,0:pver) ! Solar beam exp transm for layer
+!
+! Corresponding quantities for clear-skies
+!
+ real(r8), intent(inout) :: rdirc(nspint,pcols,0:pver) ! Clear layer reflec. to direct rad
+ real(r8), intent(inout) :: rdifc(nspint,pcols,0:pver) ! Clear layer reflec. to diffuse rad
+ real(r8), intent(inout) :: tdirc(nspint,pcols,0:pver) ! Clear layer trans. to direct rad
+ real(r8), intent(inout) :: tdifc(nspint,pcols,0:pver) ! Clear layer trans. to diffuse rad
+ real(r8), intent(inout) :: explayc(nspint,pcols,0:pver)! Solar beam exp transm clear layer
+!
+!---------------------------Local variables-----------------------------
+!
+ integer i ! Column indices
+ integer k ! Level index
+ integer nn ! Index of column loops (max=ndayc)
+
+ real(r8) taugab(pcols) ! Layer total gas absorption optical depth
+ real(r8) tauray(pcols) ! Layer rayleigh optical depth
+ real(r8) taucsc ! Layer cloud scattering optical depth
+ real(r8) tautot ! Total layer optical depth
+ real(r8) wtot ! Total layer single scatter albedo
+ real(r8) gtot ! Total layer asymmetry parameter
+ real(r8) ftot ! Total layer forward scatter fraction
+ real(r8) wtau ! rayleigh layer scattering optical depth
+ real(r8) wt ! layer total single scattering albedo
+ real(r8) ts ! layer scaled extinction optical depth
+ real(r8) ws ! layer scaled single scattering albedo
+ real(r8) gs ! layer scaled asymmetry parameter
+!
+!---------------------------Statement functions-------------------------
+!
+! Statement functions and other local variables
+!
+ real(r8) alpha ! Term in direct reflect and transmissivity
+ real(r8) gamma ! Term in direct reflect and transmissivity
+ real(r8) el ! Term in alpha,gamma,n,u
+ real(r8) taus ! Scaled extinction optical depth
+ real(r8) omgs ! Scaled single particle scattering albedo
+ real(r8) asys ! Scaled asymmetry parameter
+ real(r8) u ! Term in diffuse reflect and
+! transmissivity
+ real(r8) n ! Term in diffuse reflect and
+! transmissivity
+ real(r8) lm ! Temporary for el
+ real(r8) ne ! Temporary for n
+ real(r8) w ! Dummy argument for statement function
+ real(r8) uu ! Dummy argument for statement function
+ real(r8) g ! Dummy argument for statement function
+ real(r8) e ! Dummy argument for statement function
+ real(r8) f ! Dummy argument for statement function
+ real(r8) t ! Dummy argument for statement function
+ real(r8) et ! Dummy argument for statement function
+!
+! Intermediate terms for delta-eddington solution
+!
+ real(r8) alp ! Temporary for alpha
+ real(r8) gam ! Temporary for gamma
+ real(r8) ue ! Temporary for u
+ real(r8) arg ! Exponential argument
+ real(r8) extins ! Extinction
+ real(r8) amg ! Alp - gam
+ real(r8) apg ! Alp + gam
+!
+ alpha(w,uu,g,e) = .75_r8*w*uu*((1._r8 + g*(1._r8-w))/(1._r8 - e*e*uu*uu))
+ gamma(w,uu,g,e) = .50_r8*w*((3._r8*g*(1._r8-w)*uu*uu + 1._r8)/(1._r8-e*e*uu*uu))
+ el(w,g) = sqrt(3._r8*(1._r8-w)*(1._r8 - w*g))
+ taus(w,f,t) = (1._r8 - w*f)*t
+ omgs(w,f) = (1._r8 - f)*w/(1._r8 - w*f)
+ asys(g,f) = (g - f)/(1._r8 - f)
+ u(w,g,e) = 1.5_r8*(1._r8 - w*g)/e
+ n(uu,et) = ((uu+1._r8)*(uu+1._r8)/et ) - ((uu-1._r8)*(uu-1._r8)*et)
+!
+!-----------------------------------------------------------------------
+!
+! Compute layer radiative properties
+!
+! Compute radiative properties (reflectivity and transmissivity for
+! direct and diffuse radiation incident from above, under clear
+! and cloudy conditions) and transmission of direct radiation
+! (under clear and cloudy conditions) for each layer.
+!
+ do k=0,pver
+ do nn=1,ndayc
+ i=idayc(nn)
+ tauray(i) = trayoslp*(pflx(i,k+1)-pflx(i,k))
+ taugab(i) = abh2o*uh2o(i,k) + abo3*uo3(i,k) + abco2*uco2(i,k) + abo2*uo2(i,k)
+ tautot = tauxcl(i,k) + tauxci(i,k) + tauray(i) + taugab(i) + tauxar(i,k)
+ taucsc = tauxcl(i,k)*wcl(i,k) + tauxci(i,k)*wci(i,k) + tauxar(i,k)*wa(i,k)
+ wtau = wray*tauray(i)
+ wt = wtau + taucsc
+ wtot = wt/tautot
+ gtot = (wtau*gray + gcl(i,k)*wcl(i,k)*tauxcl(i,k) &
+ + gci(i,k)*wci(i,k)*tauxci(i,k) + ga(i,k) *wa(i,k) *tauxar(i,k))/wt
+ ftot = (wtau*fray + fcl(i,k)*wcl(i,k)*tauxcl(i,k) &
+ + fci(i,k)*wci(i,k)*tauxci(i,k) + fa(i,k) *wa(i,k) *tauxar(i,k))/wt
+ ts = taus(wtot,ftot,tautot)
+ ws = omgs(wtot,ftot)
+ gs = asys(gtot,ftot)
+ lm = el(ws,gs)
+ alp = alpha(ws,coszrs(i),gs,lm)
+ gam = gamma(ws,coszrs(i),gs,lm)
+ ue = u(ws,gs,lm)
+!
+! Limit argument of exponential to 25, in case lm very large:
+!
+ arg = min(lm*ts,25._r8)
+ extins = exp(-arg)
+ ne = n(ue,extins)
+ rdif(ns,i,k) = (ue+1._r8)*(ue-1._r8)*(1._r8/extins - extins)/ne
+ tdif(ns,i,k) = 4._r8*ue/ne
+!
+! Limit argument of exponential to 25, in case coszrs is very small:
+!
+ arg = min(ts/coszrs(i),25._r8)
+ explay(ns,i,k) = exp(-arg)
+ apg = alp + gam
+ amg = alp - gam
+ rdir(ns,i,k) = amg*(tdif(ns,i,k)*explay(ns,i,k)-1._r8) + apg*rdif(ns,i,k)
+ tdir(ns,i,k) = apg*tdif(ns,i,k) + (amg*rdif(ns,i,k)-(apg-1._r8))*explay(ns,i,k)
+!
+! Under rare conditions, reflectivies and transmissivities can be
+! negative; zero out any negative values
+!
+ rdir(ns,i,k) = max(rdir(ns,i,k),0.0_r8)
+ tdir(ns,i,k) = max(tdir(ns,i,k),0.0_r8)
+ rdif(ns,i,k) = max(rdif(ns,i,k),0.0_r8)
+ tdif(ns,i,k) = max(tdif(ns,i,k),0.0_r8)
+!
+! Clear-sky calculation
+!
+ if (tauxcl(i,k) == 0.0_r8 .and. tauxci(i,k) == 0.0_r8) then
+
+ rdirc(ns,i,k) = rdir(ns,i,k)
+ tdirc(ns,i,k) = tdir(ns,i,k)
+ rdifc(ns,i,k) = rdif(ns,i,k)
+ tdifc(ns,i,k) = tdif(ns,i,k)
+ explayc(ns,i,k) = explay(ns,i,k)
+ else
+ tautot = tauray(i) + taugab(i) + tauxar(i,k)
+ taucsc = tauxar(i,k)*wa(i,k)
+!
+! wtau already computed for all-sky
+!
+ wt = wtau + taucsc
+ wtot = wt/tautot
+ gtot = (wtau*gray + ga(i,k)*wa(i,k)*tauxar(i,k))/wt
+ ftot = (wtau*fray + fa(i,k)*wa(i,k)*tauxar(i,k))/wt
+ ts = taus(wtot,ftot,tautot)
+ ws = omgs(wtot,ftot)
+ gs = asys(gtot,ftot)
+ lm = el(ws,gs)
+ alp = alpha(ws,coszrs(i),gs,lm)
+ gam = gamma(ws,coszrs(i),gs,lm)
+ ue = u(ws,gs,lm)
+!
+! Limit argument of exponential to 25, in case lm very large:
+!
+ arg = min(lm*ts,25._r8)
+ extins = exp(-arg)
+ ne = n(ue,extins)
+ rdifc(ns,i,k) = (ue+1._r8)*(ue-1._r8)*(1._r8/extins - extins)/ne
+ tdifc(ns,i,k) = 4._r8*ue/ne
+!
+! Limit argument of exponential to 25, in case coszrs is very small:
+!
+ arg = min(ts/coszrs(i),25._r8)
+ explayc(ns,i,k) = exp(-arg)
+ apg = alp + gam
+ amg = alp - gam
+ rdirc(ns,i,k) = amg*(tdifc(ns,i,k)*explayc(ns,i,k)-1._r8)+ &
+ apg*rdifc(ns,i,k)
+ tdirc(ns,i,k) = apg*tdifc(ns,i,k) + (amg*rdifc(ns,i,k) - (apg-1._r8))* &
+ explayc(ns,i,k)
+!
+! Under rare conditions, reflectivies and transmissivities can be
+! negative; zero out any negative values
+!
+ rdirc(ns,i,k) = max(rdirc(ns,i,k),0.0_r8)
+ tdirc(ns,i,k) = max(tdirc(ns,i,k),0.0_r8)
+ rdifc(ns,i,k) = max(rdifc(ns,i,k),0.0_r8)
+ tdifc(ns,i,k) = max(tdifc(ns,i,k),0.0_r8)
+ end if
+ end do
+ end do
+
+ return
+end subroutine raddedmx
+
+subroutine radinp(lchnk ,ncol , pcols, pver, pverp, &
+ pmid ,pint ,o3vmr , pmidrd ,&
+ pintrd ,eccf ,o3mmr )
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Set latitude and time dependent arrays for input to solar
+! and longwave radiation.
+! Convert model pressures to cgs, and compute ozone mixing ratio, needed for
+! the solar radiation.
+!
+! Method:
+! <Describe the algorithm(s) used in the routine.>
+! <Also include any applicable external references.>
+!
+! Author: CCM1, CMS Contact J. Kiehl
+!
+!-----------------------------------------------------------------------
+! use shr_kind_mod, only: r8 => shr_kind_r8
+! use ppgrid
+! use time_manager, only: get_curr_calday
+
+ implicit none
+
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+ integer, intent(in) :: lchnk ! chunk identifier
+ integer, intent(in) :: pcols, pver, pverp
+ integer, intent(in) :: ncol ! number of atmospheric columns
+
+ real(r8), intent(in) :: pmid(pcols,pver) ! Pressure at model mid-levels (pascals)
+ real(r8), intent(in) :: pint(pcols,pverp) ! Pressure at model interfaces (pascals)
+ real(r8), intent(in) :: o3vmr(pcols,pver) ! ozone volume mixing ratio
+!
+! Output arguments
+!
+ real(r8), intent(out) :: pmidrd(pcols,pver) ! Pressure at mid-levels (dynes/cm*2)
+ real(r8), intent(out) :: pintrd(pcols,pverp) ! Pressure at interfaces (dynes/cm*2)
+ real(r8), intent(out) :: eccf ! Earth-sun distance factor
+ real(r8), intent(out) :: o3mmr(pcols,pver) ! Ozone mass mixing ratio
+
+!
+!---------------------------Local variables-----------------------------
+!
+ integer i ! Longitude loop index
+ integer k ! Vertical loop index
+
+ real(r8) :: calday ! current calendar day
+ real(r8) vmmr ! Ozone volume mixing ratio
+ real(r8) delta ! Solar declination angle
+
+!
+!-----------------------------------------------------------------------
+!
+! calday = get_curr_calday()
+ eccf = 1. ! declared intent(out) so fill a value (not used in WRF)
+! call shr_orb_decl (calday ,eccen ,mvelpp ,lambm0 ,obliqr , &
+! delta ,eccf)
+
+!
+! Convert pressure from pascals to dynes/cm2
+!
+ do k=1,pver
+ do i=1,ncol
+ pmidrd(i,k) = pmid(i,k)*10.0
+ pintrd(i,k) = pint(i,k)*10.0
+ end do
+ end do
+ do i=1,ncol
+ pintrd(i,pverp) = pint(i,pverp)*10.0
+ end do
+!
+! Convert ozone volume mixing ratio to mass mixing ratio:
+!
+ vmmr = amo/amd
+ do k=1,pver
+ do i=1,ncol
+ o3mmr(i,k) = vmmr*o3vmr(i,k)
+ end do
+ end do
+!
+ return
+end subroutine radinp
+subroutine radoz2(lchnk ,ncol ,pcols, pver, pverp, o3vmr ,pint ,plol ,plos, ntoplw )
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Computes the path length integrals to the model interfaces given the
+! ozone volume mixing ratio
+!
+! Method:
+! <Describe the algorithm(s) used in the routine.>
+! <Also include any applicable external references.>
+!
+! Author: CCM1, CMS Contact J. Kiehl
+!
+!-----------------------------------------------------------------------
+! use shr_kind_mod, only: r8 => shr_kind_r8
+! use ppgrid
+! use comozp
+
+ implicit none
+!------------------------------Input arguments--------------------------
+!
+ integer, intent(in) :: lchnk ! chunk identifier
+ integer, intent(in) :: ncol ! number of atmospheric columns
+ integer, intent(in) :: pcols, pver, pverp
+
+ real(r8), intent(in) :: o3vmr(pcols,pver) ! ozone volume mixing ratio
+ real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressures
+
+ integer, intent(in) :: ntoplw ! topmost level/layer longwave is solved for
+
+!
+!----------------------------Output arguments---------------------------
+!
+ real(r8), intent(out) :: plol(pcols,pverp) ! Ozone prs weighted path length (cm)
+ real(r8), intent(out) :: plos(pcols,pverp) ! Ozone path length (cm)
+
+!
+!---------------------------Local workspace-----------------------------
+!
+ integer i ! longitude index
+ integer k ! level index
+!
+!-----------------------------------------------------------------------
+!
+! Evaluate the ozone path length integrals to interfaces;
+! factors of .1 and .01 to convert pressures from cgs to mks:
+!
+ do i=1,ncol
+ plos(i,ntoplw) = 0.1 *cplos*o3vmr(i,ntoplw)*pint(i,ntoplw)
+ plol(i,ntoplw) = 0.01*cplol*o3vmr(i,ntoplw)*pint(i,ntoplw)*pint(i,ntoplw)
+ end do
+ do k=ntoplw+1,pverp
+ do i=1,ncol
+ plos(i,k) = plos(i,k-1) + 0.1*cplos*o3vmr(i,k-1)*(pint(i,k) - pint(i,k-1))
+ plol(i,k) = plol(i,k-1) + 0.01*cplol*o3vmr(i,k-1)* &
+ (pint(i,k)*pint(i,k) - pint(i,k-1)*pint(i,k-1))
+ end do
+ end do
+!
+ return
+end subroutine radoz2
+
+
+subroutine radozn (lchnk, ncol, pcols, pver,pmid, pin, levsiz, ozmix, o3vmr)
+!-----------------------------------------------------------------------
+!
+! Purpose: Interpolate ozone from current time-interpolated values to model levels
+!
+! Method: Use pressure values to determine interpolation levels
+!
+! Author: Bruce Briegleb
+!
+!--------------------------------------------------------------------------
+! use shr_kind_mod, only: r8 => shr_kind_r8
+! use ppgrid
+! use phys_grid, only: get_lat_all_p, get_lon_all_p
+! use comozp
+! use abortutils, only: endrun
+!--------------------------------------------------------------------------
+ implicit none
+!--------------------------------------------------------------------------
+!
+! Arguments
+!
+ integer, intent(in) :: lchnk ! chunk identifier
+ integer, intent(in) :: pcols, pver
+ integer, intent(in) :: ncol ! number of atmospheric columns
+ integer, intent(in) :: levsiz ! number of ozone layers
+
+ real(r8), intent(in) :: pmid(pcols,pver) ! level pressures (mks)
+ real(r8), intent(in) :: pin(levsiz) ! ozone data level pressures (mks)
+ real(r8), intent(in) :: ozmix(pcols,levsiz) ! ozone mixing ratio
+
+ real(r8), intent(out) :: o3vmr(pcols,pver) ! ozone volume mixing ratio
+!
+! local storage
+!
+ integer i ! longitude index
+ integer k, kk, kkstart ! level indices
+ integer kupper(pcols) ! Level indices for interpolation
+ integer kount ! Counter
+ integer lats(pcols) ! latitude indices
+ integer lons(pcols) ! latitude indices
+
+ real(r8) dpu ! upper level pressure difference
+ real(r8) dpl ! lower level pressure difference
+!
+! Initialize latitude indices
+!
+! call get_lat_all_p(lchnk, ncol, lats)
+! call get_lon_all_p(lchnk, ncol, lons)
+!
+! Initialize index array
+!
+ do i=1,ncol
+ kupper(i) = 1
+ end do
+
+ do k=1,pver
+!
+! Top level we need to start looking is the top level for the previous k
+! for all longitude points
+!
+ kkstart = levsiz
+ do i=1,ncol
+ kkstart = min0(kkstart,kupper(i))
+ end do
+ kount = 0
+!
+! Store level indices for interpolation
+!
+ do kk=kkstart,levsiz-1
+ do i=1,ncol
+ if (pin(kk).lt.pmid(i,k) .and. pmid(i,k).le.pin(kk+1)) then
+ kupper(i) = kk
+ kount = kount + 1
+ end if
+ end do
+!
+! If all indices for this level have been found, do the interpolation and
+! go to the next level
+!
+ if (kount.eq.ncol) then
+ do i=1,ncol
+ dpu = pmid(i,k) - pin(kupper(i))
+ dpl = pin(kupper(i)+1) - pmid(i,k)
+ o3vmr(i,k) = (ozmix(i,kupper(i))*dpl + &
+ ozmix(i,kupper(i)+1)*dpu)/(dpl + dpu)
+ end do
+ goto 35
+ end if
+ end do
+!
+! If we've fallen through the kk=1,levsiz-1 loop, we cannot interpolate and
+! must extrapolate from the bottom or top ozone data level for at least some
+! of the longitude points.
+!
+ do i=1,ncol
+ if (pmid(i,k) .lt. pin(1)) then
+ o3vmr(i,k) = ozmix(i,1)*pmid(i,k)/pin(1)
+ else if (pmid(i,k) .gt. pin(levsiz)) then
+ o3vmr(i,k) = ozmix(i,levsiz)
+ else
+ dpu = pmid(i,k) - pin(kupper(i))
+ dpl = pin(kupper(i)+1) - pmid(i,k)
+ o3vmr(i,k) = (ozmix(i,kupper(i))*dpl + &
+ ozmix(i,kupper(i)+1)*dpu)/(dpl + dpu)
+ end if
+ end do
+
+ if (kount.gt.ncol) then
+ call endrun ('RADOZN: Bad ozone data: non-monotonicity suspected')
+ end if
+35 continue
+ end do
+
+ return
+end subroutine radozn
+
+
+#endif
+
+end MODULE module_ra_cam
Added: branches/atmos_physics/src/core_physics/physics_wrf/module_ra_cam_support.F
===================================================================
--- branches/atmos_physics/src/core_physics/physics_wrf/module_ra_cam_support.F (rev 0)
+++ branches/atmos_physics/src/core_physics/physics_wrf/module_ra_cam_support.F 2011-05-20 16:44:36 UTC (rev 849)
@@ -0,0 +1,3873 @@
+MODULE module_ra_cam_support
+ use module_cam_support, only: endrun
+ implicit none
+ integer, parameter :: r8 = 8
+ real(r8), parameter:: inf = 1.e20 ! CAM sets this differently in infnan.F90
+ integer, parameter:: bigint = O'17777777777' ! largest possible 32-bit integer
+
+ integer :: ixcldliq
+ integer :: ixcldice
+! integer :: levsiz ! size of level dimension on dataset
+ integer, parameter :: nbands = 2 ! Number of spectral bands
+ integer, parameter :: naer_all = 12 + 1
+ integer, parameter :: naer = 10 + 1
+ integer, parameter :: bnd_nbr_LW=7
+ integer, parameter :: ndstsz = 4 ! number of dust size bins
+ integer :: idxSUL
+ integer :: idxSSLT
+ integer :: idxDUSTfirst
+ integer :: idxCARBONfirst
+ integer :: idxOCPHO
+ integer :: idxBCPHO
+ integer :: idxOCPHI
+ integer :: idxBCPHI
+ integer :: idxBG
+ integer :: idxVOLC
+
+ integer :: mxaerl ! Maximum level of background aerosol
+
+! indices to sections of array that represent
+! groups of aerosols
+
+ integer, parameter :: &
+ numDUST = 4, &
+ numCARBON = 4
+
+! portion of each species group to use in computation
+! of relative radiative forcing.
+
+ real(r8) :: sulscl_rf = 0._r8 !
+ real(r8) :: carscl_rf = 0._r8
+ real(r8) :: ssltscl_rf = 0._r8
+ real(r8) :: dustscl_rf = 0._r8
+ real(r8) :: bgscl_rf = 0._r8
+ real(r8) :: volcscl_rf = 0._r8
+
+! "background" aerosol species mmr.
+ real(r8) :: tauback = 0._r8
+
+! portion of each species group to use in computation
+! of aerosol forcing in driving the climate
+ real(r8) :: sulscl = 1._r8
+ real(r8) :: carscl = 1._r8
+ real(r8) :: ssltscl = 1._r8
+ real(r8) :: dustscl = 1._r8
+ real(r8) :: volcscl = 1._r8
+
+!From volcrad.F90 module
+ integer, parameter :: idx_LW_0500_0650=3
+ integer, parameter :: idx_LW_0650_0800=4
+ integer, parameter :: idx_LW_0800_1000=5
+ integer, parameter :: idx_LW_1000_1200=6
+ integer, parameter :: idx_LW_1200_2000=7
+
+! First two values represent the overlap of volcanics with the non-window
+! (0-800, 1200-2200 cm^-1) and window (800-1200 cm^-1) regions.| Coefficients
+! were derived using crm_volc_minimize.pro with spectral flux optimization
+! on first iteration, total heating rate on subsequent iterations (2-9).
+! Five profiles for HLS, HLW, MLS, MLW, and TRO conditions were given equal
+! weight. RMS heating rate errors for a visible stratospheric optical
+! depth of 1.0 are 0.02948 K/day.
+!
+ real(r8) :: abs_cff_mss_aer(bnd_nbr_LW) = &
+ (/ 70.257384, 285.282943, &
+ 1.0273851e+02, 6.3073303e+01, 1.2039569e+02, &
+ 3.6343643e+02, 2.7138528e+02 /)
+
+!From radae.F90 module
+ real(r8), parameter:: min_tp_h2o = 160.0 ! min T_p for pre-calculated abs/emis
+ real(r8), parameter:: max_tp_h2o = 349.999999 ! max T_p for pre-calculated abs/emis
+ real(r8), parameter:: dtp_h2o = 21.111111111111 ! difference in adjacent elements of tp_h2o
+ real(r8), parameter:: min_te_h2o = -120.0 ! min T_e-T_p for pre-calculated abs/emis
+ real(r8), parameter:: max_te_h2o = 79.999999 ! max T_e-T_p for pre-calculated abs/emis
+ real(r8), parameter:: dte_h2o = 10.0 ! difference in adjacent elements of te_h2o
+ real(r8), parameter:: min_rh_h2o = 0.0 ! min RH for pre-calculated abs/emis
+ real(r8), parameter:: max_rh_h2o = 1.19999999 ! max RH for pre-calculated abs/emis
+ real(r8), parameter:: drh_h2o = 0.2 ! difference in adjacent elements of RH
+ real(r8), parameter:: min_lu_h2o = -8.0 ! min log_10(U) for pre-calculated abs/emis
+ real(r8), parameter:: min_u_h2o = 1.0e-8 ! min pressure-weighted path-length
+ real(r8), parameter:: max_lu_h2o = 3.9999999 ! max log_10(U) for pre-calculated abs/emis
+ real(r8), parameter:: dlu_h2o = 0.5 ! difference in adjacent elements of lu_h2o
+ real(r8), parameter:: min_lp_h2o = -3.0 ! min log_10(P) for pre-calculated abs/emis
+ real(r8), parameter:: min_p_h2o = 1.0e-3 ! min log_10(P) for pre-calculated abs/emis
+ real(r8), parameter:: max_lp_h2o = -0.0000001 ! max log_10(P) for pre-calculated abs/emis
+ real(r8), parameter:: dlp_h2o = 0.3333333333333 ! difference in adjacent elements of lp_h2o
+ integer, parameter :: n_u = 25 ! Number of U in abs/emis tables
+ integer, parameter :: n_p = 10 ! Number of P in abs/emis tables
+ integer, parameter :: n_tp = 10 ! Number of T_p in abs/emis tables
+ integer, parameter :: n_te = 21 ! Number of T_e in abs/emis tables
+ integer, parameter :: n_rh = 7 ! Number of RH in abs/emis tables
+ real(r8):: c16,c17,c26,c27,c28,c29,c30,c31
+ real(r8):: fwcoef ! Farwing correction constant
+ real(r8):: fwc1,fwc2 ! Farwing correction constants
+ real(r8):: fc1 ! Farwing correction constant
+ real(r8):: amco2 ! Molecular weight of co2 (g/mol)
+ real(r8):: amd ! Molecular weight of dry air (g/mol)
+ real(r8):: p0 ! Standard pressure (dynes/cm**2)
+
+! These are now allocatable. JM 20090612
+ real(r8), allocatable, dimension(:,:,:,:,:) :: ah2onw ! (n_p, n_tp, n_u, n_te, n_rh) ! absorptivity (non-window)
+ real(r8), allocatable, dimension(:,:,:,:,:) :: eh2onw ! (n_p, n_tp, n_u, n_te, n_rh) ! emissivity (non-window)
+ real(r8), allocatable, dimension(:,:,:,:,:) :: ah2ow ! (n_p, n_tp, n_u, n_te, n_rh) ! absorptivity (window, for adjacent layers)
+ real(r8), allocatable, dimension(:,:,:,:,:) :: cn_ah2ow ! (n_p, n_tp, n_u, n_te, n_rh) ! continuum transmission for absorptivity (window)
+ real(r8), allocatable, dimension(:,:,:,:,:) :: cn_eh2ow ! (n_p, n_tp, n_u, n_te, n_rh) ! continuum transmission for emissivity (window)
+ real(r8), allocatable, dimension(:,:,:,:,:) :: ln_ah2ow ! (n_p, n_tp, n_u, n_te, n_rh) ! line-only transmission for absorptivity (window)
+ real(r8), allocatable, dimension(:,:,:,:,:) :: ln_eh2ow ! (n_p, n_tp, n_u, n_te, n_rh) ! line-only transmission for emissivity (window)
+
+!
+! Constant coefficients for water vapor overlap with trace gases.
+! Reference: Ramanathan, V. and P.Downey, 1986: A Nonisothermal
+! Emissivity and Absorptivity Formulation for Water Vapor
+! Journal of Geophysical Research, vol. 91., D8, pp 8649-8666
+!
+ real(r8):: coefh(2,4) = reshape( &
+ (/ (/5.46557e+01,-7.30387e-02/), &
+ (/1.09311e+02,-1.46077e-01/), &
+ (/5.11479e+01,-6.82615e-02/), &
+ (/1.02296e+02,-1.36523e-01/) /), (/2,4/) )
+!
+ real(r8):: coefj(3,2) = reshape( &
+ (/ (/2.82096e-02,2.47836e-04,1.16904e-06/), &
+ (/9.27379e-02,8.04454e-04,6.88844e-06/) /), (/3,2/) )
+!
+ real(r8):: coefk(3,2) = reshape( &
+ (/ (/2.48852e-01,2.09667e-03,2.60377e-06/) , &
+ (/1.03594e+00,6.58620e-03,4.04456e-06/) /), (/3,2/) )
+
+ integer, parameter :: ntemp = 192 ! Number of temperatures in H2O sat. table for Tp
+ real(r8) :: estblh2o(0:ntemp) ! saturation vapor pressure for H2O for Tp rang
+ integer, parameter :: o_fa = 6 ! Degree+1 of poly of T_e for absorptivity as U->inf.
+ integer, parameter :: o_fe = 6 ! Degree+1 of poly of T_e for emissivity as U->inf.
+
+!-----------------------------------------------------------------------------
+! Data for f in C/H/E fit -- value of A and E as U->infinity
+! New C/LT/E fit (Hitran 2K, CKD 2.4) -- no change
+! These values are determined by integrals of Planck functions or
+! derivatives of Planck functions only.
+!-----------------------------------------------------------------------------
+!
+! fa/fe coefficients for 2 bands (0-800 & 1200-2200, 800-1200 cm^-1)
+!
+! Coefficients of polynomial for f_a in T_e
+!
+ real(r8), parameter:: fat(o_fa,nbands) = reshape( (/ &
+ (/-1.06665373E-01, 2.90617375E-02, -2.70642049E-04, & ! 0-800&1200-2200 cm^-1
+ 1.07595511E-06, -1.97419681E-09, 1.37763374E-12/), & ! 0-800&1200-2200 cm^-1
+ (/ 1.10666537E+00, -2.90617375E-02, 2.70642049E-04, & ! 800-1200 cm^-1
+ -1.07595511E-06, 1.97419681E-09, -1.37763374E-12/) /) & ! 800-1200 cm^-1
+ , (/o_fa,nbands/) )
+!
+! Coefficients of polynomial for f_e in T_e
+!
+ real(r8), parameter:: fet(o_fe,nbands) = reshape( (/ &
+ (/3.46148163E-01, 1.51240299E-02, -1.21846479E-04, & ! 0-800&1200-2200 cm^-1
+ 4.04970123E-07, -6.15368936E-10, 3.52415071E-13/), & ! 0-800&1200-2200 cm^-1
+ (/6.53851837E-01, -1.51240299E-02, 1.21846479E-04, & ! 800-1200 cm^-1
+ -4.04970123E-07, 6.15368936E-10, -3.52415071E-13/) /) & ! 800-1200 cm^-1
+ , (/o_fa,nbands/) )
+
+
+ real(r8) :: gravit ! Acceleration of gravity (cgs)
+ real(r8) :: rga ! 1./gravit
+ real(r8) :: gravmks ! Acceleration of gravity (mks)
+ real(r8) :: cpair ! Specific heat of dry air
+ real(r8) :: epsilo ! Ratio of mol. wght of H2O to dry air
+ real(r8) :: epsqs ! Ratio of mol. wght of H2O to dry air
+ real(r8) :: sslp ! Standard sea-level pressure
+ real(r8) :: stebol ! Stefan-Boltzmann's constant
+ real(r8) :: rgsslp ! 0.5/(gravit*sslp)
+ real(r8) :: dpfo3 ! Voigt correction factor for O3
+ real(r8) :: dpfco2 ! Voigt correction factor for CO2
+ real(r8) :: dayspy ! Number of days per 1 year
+ real(r8) :: pie ! 3.14.....
+ real(r8) :: mwdry ! molecular weight dry air ~ kg/kmole (shr_const_mwdair)
+ real(r8) :: scon ! solar constant (not used in WRF)
+ real(r8) :: co2mmr
+real(r8) :: mwco2 ! molecular weight of carbon dioxide
+real(r8) :: mwh2o ! molecular weight water vapor (shr_const_mwwv)
+real(r8) :: mwch4 ! molecular weight ch4
+real(r8) :: mwn2o ! molecular weight n2o
+real(r8) :: mwf11 ! molecular weight cfc11
+real(r8) :: mwf12 ! molecular weight cfc12
+real(r8) :: cappa ! R/Cp
+real(r8) :: rair ! Gas constant for dry air (J/K/kg)
+real(r8) :: tmelt ! freezing T of fresh water ~ K
+real(r8) :: r_universal ! Universal gas constant ~ J/K/kmole
+real(r8) :: latvap ! latent heat of evaporation ~ J/kg
+real(r8) :: latice ! latent heat of fusion ~ J/kg
+real(r8) :: zvir ! R_V/R_D - 1.
+ integer plenest ! length of saturation vapor pressure table
+ parameter (plenest=250)
+!
+! Table of saturation vapor pressure values es from tmin degrees
+! to tmax+1 degrees k in one degree increments. ttrice defines the
+! transition region where es is a combination of ice & water values
+!
+real(r8) estbl(plenest) ! table values of saturation vapor pressure
+real(r8) tmin ! min temperature (K) for table
+real(r8) tmax ! max temperature (K) for table
+real(r8) pcf(6) ! polynomial coeffs -> es transition water to ice
+!real(r8), allocatable :: pin(:) ! ozone pressure level (levsiz)
+!real(r8), allocatable :: ozmix(:,:,:) ! mixing ratio
+!real(r8), allocatable, target :: abstot_3d(:,:,:,:) ! Non-adjacent layer absorptivites
+!real(r8), allocatable, target :: absnxt_3d(:,:,:,:) ! Nearest layer absorptivities
+!real(r8), allocatable, target :: emstot_3d(:,:,:) ! Total emissivity
+
+!From aer_optics.F90 module
+integer, parameter :: idxVIS = 8 ! index to visible band
+integer, parameter :: nrh = 1000 ! number of relative humidity values for look-up-table
+integer, parameter :: nspint = 19 ! number of spectral intervals
+
+! These are now allocatable, JM 20090612
+real(r8), allocatable, dimension(:,:) :: ksul ! (nrh, nspint) ! sulfate specific extinction ( m^2 g-1 )
+real(r8), allocatable, dimension(:,:) :: wsul ! (nrh, nspint) ! sulfate single scattering albedo
+real(r8), allocatable, dimension(:,:) :: gsul ! (nrh, nspint) ! sulfate asymmetry parameter
+real(r8), allocatable, dimension(:,:) :: ksslt ! (nrh, nspint) ! sea-salt specific extinction ( m^2 g-1 )
+real(r8), allocatable, dimension(:,:) :: wsslt ! (nrh, nspint) ! sea-salt single scattering albedo
+real(r8), allocatable, dimension(:,:) :: gsslt ! (nrh, nspint) ! sea-salt asymmetry parameter
+real(r8), allocatable, dimension(:,:) :: kcphil ! (nrh, nspint) ! hydrophilic carbon specific extinction ( m^2 g-1 )
+real(r8), allocatable, dimension(:,:) :: wcphil ! (nrh, nspint) ! hydrophilic carbon single scattering albedo
+real(r8), allocatable, dimension(:,:) :: gcphil ! (nrh, nspint) ! hydrophilic carbon asymmetry parameter
+
+real(r8) :: kbg(nspint) ! background specific extinction ( m^2 g-1 )
+real(r8) :: wbg(nspint) ! background single scattering albedo
+real(r8) :: gbg(nspint) ! background asymmetry parameter
+real(r8) :: kcphob(nspint) ! hydrophobic carbon specific extinction ( m^2 g-1 )
+real(r8) :: wcphob(nspint) ! hydrophobic carbon single scattering albedo
+real(r8) :: gcphob(nspint) ! hydrophobic carbon asymmetry parameter
+real(r8) :: kcb(nspint) ! black carbon specific extinction ( m^2 g-1 )
+real(r8) :: wcb(nspint) ! black carbon single scattering albedo
+real(r8) :: gcb(nspint) ! black carbon asymmetry parameter
+real(r8) :: kvolc(nspint) ! volcanic specific extinction ( m^2 g-1)
+real(r8) :: wvolc(nspint) ! volcanic single scattering albedo
+real(r8) :: gvolc(nspint) ! volcanic asymmetry parameter
+
+real(r8) :: kdst(ndstsz, nspint) ! dust specific extinction ( m^2 g-1 )
+real(r8) :: wdst(ndstsz, nspint) ! dust single scattering albedo
+real(r8) :: gdst(ndstsz, nspint) ! dust asymmetry parameter
+!
+!From comozp.F90 module
+ real(r8) cplos ! constant for ozone path length integral
+ real(r8) cplol ! constant for ozone path length integral
+
+!From ghg_surfvals.F90 module
+ real(r8) :: co2vmr = 3.550e-4 ! co2 volume mixing ratio
+ real(r8) :: n2ovmr = 0.311e-6 ! n2o volume mixing ratio
+ real(r8) :: ch4vmr = 1.714e-6 ! ch4 volume mixing ratio
+ real(r8) :: f11vmr = 0.280e-9 ! cfc11 volume mixing ratio
+ real(r8) :: f12vmr = 0.503e-9 ! cfc12 volume mixing ratio
+
+integer, parameter :: cyr = 233 ! number of years of co2 data
+
+ integer :: yrdata(cyr) = &
+ (/ 1869, 1870, 1871, 1872, 1873, 1874, 1875, &
+ 1876, 1877, 1878, 1879, 1880, 1881, 1882, &
+ 1883, 1884, 1885, 1886, 1887, 1888, 1889, &
+ 1890, 1891, 1892, 1893, 1894, 1895, 1896, &
+ 1897, 1898, 1899, 1900, 1901, 1902, 1903, &
+ 1904, 1905, 1906, 1907, 1908, 1909, 1910, &
+ 1911, 1912, 1913, 1914, 1915, 1916, 1917, &
+ 1918, 1919, 1920, 1921, 1922, 1923, 1924, &
+ 1925, 1926, 1927, 1928, 1929, 1930, 1931, &
+ 1932, 1933, 1934, 1935, 1936, 1937, 1938, &
+ 1939, 1940, 1941, 1942, 1943, 1944, 1945, &
+ 1946, 1947, 1948, 1949, 1950, 1951, 1952, &
+ 1953, 1954, 1955, 1956, 1957, 1958, 1959, &
+ 1960, 1961, 1962, 1963, 1964, 1965, 1966, &
+ 1967, 1968, 1969, 1970, 1971, 1972, 1973, &
+ 1974, 1975, 1976, 1977, 1978, 1979, 1980, &
+ 1981, 1982, 1983, 1984, 1985, 1986, 1987, &
+ 1988, 1989, 1990, 1991, 1992, 1993, 1994, &
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, &
+ 2002, 2003, 2004, 2005, 2006, 2007, 2008, &
+ 2009, 2010, 2011, 2012, 2013, 2014, 2015, &
+ 2016, 2017, 2018, 2019, 2020, 2021, 2022, &
+ 2023, 2024, 2025, 2026, 2027, 2028, 2029, &
+ 2030, 2031, 2032, 2033, 2034, 2035, 2036, &
+ 2037, 2038, 2039, 2040, 2041, 2042, 2043, &
+ 2044, 2045, 2046, 2047, 2048, 2049, 2050, &
+ 2051, 2052, 2053, 2054, 2055, 2056, 2057, &
+ 2058, 2059, 2060, 2061, 2062, 2063, 2064, &
+ 2065, 2066, 2067, 2068, 2069, 2070, 2071, &
+ 2072, 2073, 2074, 2075, 2076, 2077, 2078, &
+ 2079, 2080, 2081, 2082, 2083, 2084, 2085, &
+ 2086, 2087, 2088, 2089, 2090, 2091, 2092, &
+ 2093, 2094, 2095, 2096, 2097, 2098, 2099, &
+ 2100, 2101 /)
+
+! A2 future scenario
+ real(r8) :: co2(cyr) = &
+ (/ 289.263, 289.263, 289.416, 289.577, 289.745, 289.919, 290.102, &
+ 290.293, 290.491, 290.696, 290.909, 291.129, 291.355, 291.587, 291.824, &
+ 292.066, 292.313, 292.563, 292.815, 293.071, 293.328, 293.586, 293.843, &
+ 294.098, 294.35, 294.598, 294.842, 295.082, 295.32, 295.558, 295.797, &
+ 296.038, 296.284, 296.535, 296.794, 297.062, 297.338, 297.62, 297.91, &
+ 298.204, 298.504, 298.806, 299.111, 299.419, 299.729, 300.04, 300.352, &
+ 300.666, 300.98, 301.294, 301.608, 301.923, 302.237, 302.551, 302.863, &
+ 303.172, 303.478, 303.779, 304.075, 304.366, 304.651, 304.93, 305.206, &
+ 305.478, 305.746, 306.013, 306.28, 306.546, 306.815, 307.087, 307.365, &
+ 307.65, 307.943, 308.246, 308.56, 308.887, 309.228, 309.584, 309.956, &
+ 310.344, 310.749, 311.172, 311.614, 312.077, 312.561, 313.068, 313.599, &
+ 314.154, 314.737, 315.347, 315.984, 316.646, 317.328, 318.026, 318.742, &
+ 319.489, 320.282, 321.133, 322.045, 323.021, 324.06, 325.155, 326.299, &
+ 327.484, 328.698, 329.933, 331.194, 332.499, 333.854, 335.254, 336.69, &
+ 338.15, 339.628, 341.125, 342.65, 344.206, 345.797, 347.397, 348.98, &
+ 350.551, 352.1, 354.3637, 355.7772, 357.1601, 358.5306, 359.9046, &
+ 361.4157, 363.0445, 364.7761, 366.6064, 368.5322, 370.534, 372.5798, &
+ 374.6564, 376.7656, 378.9087, 381.0864, 383.2994, 385.548, 387.8326, &
+ 390.1536, 392.523, 394.9625, 397.4806, 400.075, 402.7444, 405.4875, &
+ 408.3035, 411.1918, 414.1518, 417.1831, 420.2806, 423.4355, 426.6442, &
+ 429.9076, 433.2261, 436.6002, 440.0303, 443.5168, 447.06, 450.6603, &
+ 454.3059, 457.9756, 461.6612, 465.3649, 469.0886, 472.8335, 476.6008, &
+ 480.3916, 484.2069, 488.0473, 491.9184, 495.8295, 499.7849, 503.7843, &
+ 507.8278, 511.9155, 516.0476, 520.2243, 524.4459, 528.7127, 533.0213, &
+ 537.3655, 541.7429, 546.1544, 550.6005, 555.0819, 559.5991, 564.1525, &
+ 568.7429, 573.3701, 578.0399, 582.7611, 587.5379, 592.3701, 597.2572, &
+ 602.1997, 607.1975, 612.2507, 617.3596, 622.524, 627.7528, 633.0616, &
+ 638.457, 643.9384, 649.505, 655.1568, 660.8936, 666.7153, 672.6219, &
+ 678.6133, 684.6945, 690.8745, 697.1569, 703.5416, 710.0284, 716.6172, &
+ 723.308, 730.1008, 736.9958, 743.993, 751.0975, 758.3183, 765.6594, &
+ 773.1207, 780.702, 788.4033, 796.2249, 804.1667, 812.2289, 820.4118, &
+ 828.6444, 828.6444 /)
+
+ integer :: ntoplw ! top level to solve for longwave cooling (WRF sets this to 1 for model top below 10 mb)
+
+ logical :: masterproc = .true.
+ logical :: ozncyc ! true => cycle ozone dataset
+! logical :: dosw ! True => shortwave calculation this timestep
+! logical :: dolw ! True => longwave calculation this timestep
+ logical :: indirect ! True => include indirect radiative effects of sulfate aerosols
+! logical :: doabsems ! True => abs/emiss calculation this timestep
+ logical :: radforce = .false. ! True => calculate aerosol shortwave forcing
+ logical :: trace_gas=.false. ! set true for chemistry
+ logical :: strat_volcanic = .false. ! True => volcanic aerosol mass available
+
+ real(r8) retab(95)
+ !
+ ! Tabulated values of re(T) in the temperature interval
+ ! 180 K -- 274 K; hexagonal columns assumed:
+ !
+ data retab / &
+ 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, &
+ 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, &
+ 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, &
+ 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, &
+ 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, &
+ 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, &
+ 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, &
+ 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, &
+ 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, &
+ 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, &
+ 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, &
+ 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, &
+ 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, &
+ 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, &
+ 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, &
+ 205.728, 214.055, 222.694, 231.661, 240.971, 250.639/
+ !
+ save retab
+contains
+
+
+
+subroutine sortarray(n, ain, indxa)
+!-----------------------------------------------
+!
+! Purpose:
+! Sort an array
+! Alogrithm:
+! Based on Shell's sorting method.
+!
+! Author: T. Craig
+!-----------------------------------------------
+! use shr_kind_mod, only: r8 => shr_kind_r8
+ implicit none
+!
+! Arguments
+!
+ integer , intent(in) :: n ! total number of elements
+ integer , intent(inout) :: indxa(n) ! array of integers
+ real(r8), intent(inout) :: ain(n) ! array to sort
+!
+! local variables
+!
+ integer :: i, j ! Loop indices
+ integer :: ni ! Starting increment
+ integer :: itmp ! Temporary index
+ real(r8):: atmp ! Temporary value to swap
+
+ ni = 1
+ do while(.TRUE.)
+ ni = 3*ni + 1
+ if (ni <= n) cycle
+ exit
+ end do
+
+ do while(.TRUE.)
+ ni = ni/3
+ do i = ni + 1, n
+ atmp = ain(i)
+ itmp = indxa(i)
+ j = i
+ do while(.TRUE.)
+ if (ain(j-ni) <= atmp) exit
+ ain(j) = ain(j-ni)
+ indxa(j) = indxa(j-ni)
+ j = j - ni
+ if (j > ni) cycle
+ exit
+ end do
+ ain(j) = atmp
+ indxa(j) = itmp
+ end do
+ if (ni > 1) cycle
+ exit
+ end do
+ return
+
+end subroutine sortarray
+subroutine trcab(lchnk ,ncol ,pcols, pverp, &
+ k1 ,k2 ,ucfc11 ,ucfc12 ,un2o0 , &
+ un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , &
+ uco221 ,uco222 ,uco223 ,bn2o0 ,bn2o1 , &
+ bch4 ,to3co2 ,pnm ,dw ,pnew , &
+ s2c ,uptype ,dplh2o ,abplnk1 ,tco2 , &
+ th2o ,to3 ,abstrc , &
+ aer_trn_ttl)
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Calculate absorptivity for non nearest layers for CH4, N2O, CFC11 and
+! CFC12.
+!
+! Method:
+! See CCM3 description for equations.
+!
+! Author: J. Kiehl
+!
+!-----------------------------------------------------------------------
+! use shr_kind_mod, only: r8 => shr_kind_r8
+! use ppgrid
+! use volcrad
+
+ implicit none
+
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+ integer, intent(in) :: lchnk ! chunk identifier
+ integer, intent(in) :: ncol ! number of atmospheric columns
+ integer, intent(in) :: pcols, pverp
+ integer, intent(in) :: k1,k2 ! level indices
+!
+ real(r8), intent(in) :: to3co2(pcols) ! pressure weighted temperature
+ real(r8), intent(in) :: pnm(pcols,pverp) ! interface pressures
+ real(r8), intent(in) :: ucfc11(pcols,pverp) ! CFC11 path length
+ real(r8), intent(in) :: ucfc12(pcols,pverp) ! CFC12 path length
+ real(r8), intent(in) :: un2o0(pcols,pverp) ! N2O path length
+!
+ real(r8), intent(in) :: un2o1(pcols,pverp) ! N2O path length (hot band)
+ real(r8), intent(in) :: uch4(pcols,pverp) ! CH4 path length
+ real(r8), intent(in) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length
+ real(r8), intent(in) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length
+ real(r8), intent(in) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length
+!
+ real(r8), intent(in) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length
+ real(r8), intent(in) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length
+ real(r8), intent(in) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length
+ real(r8), intent(in) :: bn2o0(pcols,pverp) ! pressure factor for n2o
+ real(r8), intent(in) :: bn2o1(pcols,pverp) ! pressure factor for n2o
+!
+ real(r8), intent(in) :: bch4(pcols,pverp) ! pressure factor for ch4
+ real(r8), intent(in) :: dw(pcols) ! h2o path length
+ real(r8), intent(in) :: pnew(pcols) ! pressure
+ real(r8), intent(in) :: s2c(pcols,pverp) ! continuum path length
+ real(r8), intent(in) :: uptype(pcols,pverp) ! p-type h2o path length
+!
+ real(r8), intent(in) :: dplh2o(pcols) ! p squared h2o path length
+ real(r8), intent(in) :: abplnk1(14,pcols,pverp) ! Planck factor
+ real(r8), intent(in) :: tco2(pcols) ! co2 transmission factor
+ real(r8), intent(in) :: th2o(pcols) ! h2o transmission factor
+ real(r8), intent(in) :: to3(pcols) ! o3 transmission factor
+
+ real(r8), intent(in) :: aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! aer trn.
+
+!
+! Output Arguments
+!
+ real(r8), intent(out) :: abstrc(pcols) ! total trace gas absorptivity
+!
+!--------------------------Local Variables------------------------------
+!
+ integer i,l ! loop counters
+
+ real(r8) sqti(pcols) ! square root of mean temp
+ real(r8) du1 ! cfc11 path length
+ real(r8) du2 ! cfc12 path length
+ real(r8) acfc1 ! cfc11 absorptivity 798 cm-1
+ real(r8) acfc2 ! cfc11 absorptivity 846 cm-1
+!
+ real(r8) acfc3 ! cfc11 absorptivity 933 cm-1
+ real(r8) acfc4 ! cfc11 absorptivity 1085 cm-1
+ real(r8) acfc5 ! cfc12 absorptivity 889 cm-1
+ real(r8) acfc6 ! cfc12 absorptivity 923 cm-1
+ real(r8) acfc7 ! cfc12 absorptivity 1102 cm-1
+!
+ real(r8) acfc8 ! cfc12 absorptivity 1161 cm-1
+ real(r8) du01 ! n2o path length
+ real(r8) dbeta01 ! n2o pressure factor
+ real(r8) dbeta11 ! "
+ real(r8) an2o1 ! absorptivity of 1285 cm-1 n2o band
+!
+ real(r8) du02 ! n2o path length
+ real(r8) dbeta02 ! n2o pressure factor
+ real(r8) an2o2 ! absorptivity of 589 cm-1 n2o band
+ real(r8) du03 ! n2o path length
+ real(r8) dbeta03 ! n2o pressure factor
+!
+ real(r8) an2o3 ! absorptivity of 1168 cm-1 n2o band
+ real(r8) duch4 ! ch4 path length
+ real(r8) dbetac ! ch4 pressure factor
+ real(r8) ach4 ! absorptivity of 1306 cm-1 ch4 band
+ real(r8) du11 ! co2 path length
+!
+ real(r8) du12 ! "
+ real(r8) du13 ! "
+ real(r8) dbetc1 ! co2 pressure factor
+ real(r8) dbetc2 ! co2 pressure factor
+ real(r8) aco21 ! absorptivity of 1064 cm-1 band
+!
+ real(r8) du21 ! co2 path length
+ real(r8) du22 ! "
+ real(r8) du23 ! "
+ real(r8) aco22 ! absorptivity of 961 cm-1 band
+ real(r8) tt(pcols) ! temp. factor for h2o overlap factor
+!
+ real(r8) psi1 ! "
+ real(r8) phi1 ! "
+ real(r8) p1 ! h2o overlap factor
+ real(r8) w1 ! "
+ real(r8) ds2c(pcols) ! continuum path length
+!
+ real(r8) duptyp(pcols) ! p-type path length
+ real(r8) tw(pcols,6) ! h2o transmission factor
+ real(r8) g1(6) ! "
+ real(r8) g2(6) ! "
+ real(r8) g3(6) ! "
+!
+ real(r8) g4(6) ! "
+ real(r8) ab(6) ! h2o temp. factor
+ real(r8) bb(6) ! "
+ real(r8) abp(6) ! "
+ real(r8) bbp(6) ! "
+!
+ real(r8) tcfc3 ! transmission for cfc11 band
+ real(r8) tcfc4 ! transmission for cfc11 band
+ real(r8) tcfc6 ! transmission for cfc12 band
+ real(r8) tcfc7 ! transmission for cfc12 band
+ real(r8) tcfc8 ! transmission for cfc12 band
+!
+ real(r8) tlw ! h2o transmission
+ real(r8) tch4 ! ch4 transmission
+!
+!--------------------------Data Statements------------------------------
+!
+ data g1 /0.0468556,0.0397454,0.0407664,0.0304380,0.0540398,0.0321962/
+ data g2 /14.4832,4.30242,5.23523,3.25342,0.698935,16.5599/
+ data g3 /26.1898,18.4476,15.3633,12.1927,9.14992,8.07092/
+ data g4 /0.0261782,0.0369516,0.0307266,0.0243854,0.0182932,0.0161418/
+ data ab /3.0857e-2,2.3524e-2,1.7310e-2,2.6661e-2,2.8074e-2,2.2915e-2/
+ data bb /-1.3512e-4,-6.8320e-5,-3.2609e-5,-1.0228e-5,-9.5743e-5,-1.0304e-4/
+ data abp/2.9129e-2,2.4101e-2,1.9821e-2,2.6904e-2,2.9458e-2,1.9892e-2/
+ data bbp/-1.3139e-4,-5.5688e-5,-4.6380e-5,-8.0362e-5,-1.0115e-4,-8.8061e-5/
+!
+!--------------------------Statement Functions--------------------------
+!
+ real(r8) func, u, b
+ func(u,b) = u/sqrt(4.0 + u*(1.0 + 1.0 / b))
+!
+!------------------------------------------------------------------------
+!
+ do i = 1,ncol
+ sqti(i) = sqrt(to3co2(i))
+!
+! h2o transmission
+!
+ tt(i) = abs(to3co2(i) - 250.0)
+ ds2c(i) = abs(s2c(i,k1) - s2c(i,k2))
+ duptyp(i) = abs(uptype(i,k1) - uptype(i,k2))
+ end do
+!
+ do l = 1,6
+ do i = 1,ncol
+ psi1 = exp(abp(l)*tt(i) + bbp(l)*tt(i)*tt(i))
+ phi1 = exp(ab(l)*tt(i) + bb(l)*tt(i)*tt(i))
+ p1 = pnew(i)*(psi1/phi1)/sslp
+ w1 = dw(i)*phi1
+ tw(i,l) = exp(-g1(l)*p1*(sqrt(1.0 + g2(l)*(w1/p1)) - 1.0) - &
+ g3(l)*ds2c(i)-g4(l)*duptyp(i))
+ end do
+ end do
+!
+ do i=1,ncol
+ tw(i,1)=tw(i,1)*(0.7*aer_trn_ttl(i,k1,k2,idx_LW_0650_0800)+&! l=1: 0750--0820 cm-1
+ 0.3*aer_trn_ttl(i,k1,k2,idx_LW_0800_1000))
+ tw(i,2)=tw(i,2)*aer_trn_ttl(i,k1,k2,idx_LW_0800_1000) ! l=2: 0820--0880 cm-1
+ tw(i,3)=tw(i,3)*aer_trn_ttl(i,k1,k2,idx_LW_0800_1000) ! l=3: 0880--0900 cm-1
+ tw(i,4)=tw(i,4)*aer_trn_ttl(i,k1,k2,idx_LW_0800_1000) ! l=4: 0900--1000 cm-1
+ tw(i,5)=tw(i,5)*aer_trn_ttl(i,k1,k2,idx_LW_1000_1200) ! l=5: 1000--1120 cm-1
+ tw(i,6)=tw(i,6)*aer_trn_ttl(i,k1,k2,idx_LW_1000_1200) ! l=6: 1120--1170 cm-1
+ end do ! end loop over lon
+ do i = 1,ncol
+ du1 = abs(ucfc11(i,k1) - ucfc11(i,k2))
+ du2 = abs(ucfc12(i,k1) - ucfc12(i,k2))
+!
+! cfc transmissions
+!
+ tcfc3 = exp(-175.005*du1)
+ tcfc4 = exp(-1202.18*du1)
+ tcfc6 = exp(-5786.73*du2)
+ tcfc7 = exp(-2873.51*du2)
+ tcfc8 = exp(-2085.59*du2)
+!
+! Absorptivity for CFC11 bands
+!
+ acfc1 = 50.0*(1.0 - exp(-54.09*du1))*tw(i,1)*abplnk1(7,i,k2)
+ acfc2 = 60.0*(1.0 - exp(-5130.03*du1))*tw(i,2)*abplnk1(8,i,k2)
+ acfc3 = 60.0*(1.0 - tcfc3)*tw(i,4)*tcfc6*abplnk1(9,i,k2)
+ acfc4 = 100.0*(1.0 - tcfc4)*tw(i,5)*abplnk1(10,i,k2)
+!
+! Absorptivity for CFC12 bands
+!
+ acfc5 = 45.0*(1.0 - exp(-1272.35*du2))*tw(i,3)*abplnk1(11,i,k2)
+ acfc6 = 50.0*(1.0 - tcfc6)* tw(i,4) * abplnk1(12,i,k2)
+ acfc7 = 80.0*(1.0 - tcfc7)* tw(i,5) * tcfc4*abplnk1(13,i,k2)
+ acfc8 = 70.0*(1.0 - tcfc8)* tw(i,6) * abplnk1(14,i,k2)
+!
+! Emissivity for CH4 band 1306 cm-1
+!
+ tlw = exp(-1.0*sqrt(dplh2o(i)))
+ tlw=tlw*aer_trn_ttl(i,k1,k2,idx_LW_1200_2000)
+ duch4 = abs(uch4(i,k1) - uch4(i,k2))
+ dbetac = abs(bch4(i,k1) - bch4(i,k2))/duch4
+ ach4 = 6.00444*sqti(i)*log(1.0 + func(duch4,dbetac))*tlw*abplnk1(3,i,k2)
+ tch4 = 1.0/(1.0 + 0.02*func(duch4,dbetac))
+!
+! Absorptivity for N2O bands
+!
+ du01 = abs(un2o0(i,k1) - un2o0(i,k2))
+ du11 = abs(un2o1(i,k1) - un2o1(i,k2))
+ dbeta01 = abs(bn2o0(i,k1) - bn2o0(i,k2))/du01
+ dbeta11 = abs(bn2o1(i,k1) - bn2o1(i,k2))/du11
+!
+! 1285 cm-1 band
+!
+ an2o1 = 2.35558*sqti(i)*log(1.0 + func(du01,dbeta01) &
+ + func(du11,dbeta11))*tlw*tch4*abplnk1(4,i,k2)
+ du02 = 0.100090*du01
+ du12 = 0.0992746*du11
+ dbeta02 = 0.964282*dbeta01
+!
+! 589 cm-1 band
+!
+ an2o2 = 2.65581*sqti(i)*log(1.0 + func(du02,dbeta02) + &
+ func(du12,dbeta02))*th2o(i)*tco2(i)*abplnk1(5,i,k2)
+ du03 = 0.0333767*du01
+ dbeta03 = 0.982143*dbeta01
+!
+! 1168 cm-1 band
+!
+ an2o3 = 2.54034*sqti(i)*log(1.0 + func(du03,dbeta03))* &
+ tw(i,6)*tcfc8*abplnk1(6,i,k2)
+!
+! Emissivity for 1064 cm-1 band of CO2
+!
+ du11 = abs(uco211(i,k1) - uco211(i,k2))
+ du12 = abs(uco212(i,k1) - uco212(i,k2))
+ du13 = abs(uco213(i,k1) - uco213(i,k2))
+ dbetc1 = 2.97558*abs(pnm(i,k1) + pnm(i,k2))/(2.0*sslp*sqti(i))
+ dbetc2 = 2.0*dbetc1
+ aco21 = 3.7571*sqti(i)*log(1.0 + func(du11,dbetc1) &
+ + func(du12,dbetc2) + func(du13,dbetc2)) &
+ *to3(i)*tw(i,5)*tcfc4*tcfc7*abplnk1(2,i,k2)
+!
+! Emissivity for 961 cm-1 band
+!
+ du21 = abs(uco221(i,k1) - uco221(i,k2))
+ du22 = abs(uco222(i,k1) - uco222(i,k2))
+ du23 = abs(uco223(i,k1) - uco223(i,k2))
+ aco22 = 3.8443*sqti(i)*log(1.0 + func(du21,dbetc1) &
+ + func(du22,dbetc1) + func(du23,dbetc2)) &
+ *tw(i,4)*tcfc3*tcfc6*abplnk1(1,i,k2)
+!
+! total trace gas absorptivity
+!
+ abstrc(i) = acfc1 + acfc2 + acfc3 + acfc4 + acfc5 + acfc6 + &
+ acfc7 + acfc8 + an2o1 + an2o2 + an2o3 + ach4 + &
+ aco21 + aco22
+ end do
+!
+ return
+!
+end subroutine trcab
+
+
+
+subroutine trcabn(lchnk ,ncol ,pcols, pverp, &
+ k2 ,kn ,ucfc11 ,ucfc12 ,un2o0 , &
+ un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , &
+ uco221 ,uco222 ,uco223 ,tbar ,bplnk , &
+ winpl ,pinpl ,tco2 ,th2o ,to3 , &
+ uptype ,dw ,s2c ,up2 ,pnew , &
+ abstrc ,uinpl , &
+ aer_trn_ngh)
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Calculate nearest layer absorptivity due to CH4, N2O, CFC11 and CFC12
+!
+! Method:
+! Equations in CCM3 description
+!
+! Author: J. Kiehl
+!
+!-----------------------------------------------------------------------
+!
+! use shr_kind_mod, only: r8 => shr_kind_r8
+! use ppgrid
+! use volcrad
+
+ implicit none
+
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+ integer, intent(in) :: lchnk ! chunk identifier
+ integer, intent(in) :: ncol ! number of atmospheric columns
+ integer, intent(in) :: pcols, pverp
+ integer, intent(in) :: k2 ! level index
+ integer, intent(in) :: kn ! level index
+!
+ real(r8), intent(in) :: tbar(pcols,4) ! pressure weighted temperature
+ real(r8), intent(in) :: ucfc11(pcols,pverp) ! CFC11 path length
+ real(r8), intent(in) :: ucfc12(pcols,pverp) ! CFC12 path length
+ real(r8), intent(in) :: un2o0(pcols,pverp) ! N2O path length
+ real(r8), intent(in) :: un2o1(pcols,pverp) ! N2O path length (hot band)
+!
+ real(r8), intent(in) :: uch4(pcols,pverp) ! CH4 path length
+ real(r8), intent(in) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length
+ real(r8), intent(in) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length
+ real(r8), intent(in) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length
+ real(r8), intent(in) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length
+!
+ real(r8), intent(in) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length
+ real(r8), intent(in) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length
+ real(r8), intent(in) :: bplnk(14,pcols,4) ! weighted Planck fnc. for absorptivity
+ real(r8), intent(in) :: winpl(pcols,4) ! fractional path length
+ real(r8), intent(in) :: pinpl(pcols,4) ! pressure factor for subdivided layer
+!
+ real(r8), intent(in) :: tco2(pcols) ! co2 transmission
+ real(r8), intent(in) :: th2o(pcols) ! h2o transmission
+ real(r8), intent(in) :: to3(pcols) ! o3 transmission
+ real(r8), intent(in) :: dw(pcols) ! h2o path length
+ real(r8), intent(in) :: pnew(pcols) ! pressure factor
+!
+ real(r8), intent(in) :: s2c(pcols,pverp) ! h2o continuum factor
+ real(r8), intent(in) :: uptype(pcols,pverp) ! p-type path length
+ real(r8), intent(in) :: up2(pcols) ! p squared path length
+ real(r8), intent(in) :: uinpl(pcols,4) ! Nearest layer subdivision factor
+ real(r8), intent(in) :: aer_trn_ngh(pcols,bnd_nbr_LW)
+ ! [fraction] Total transmission between
+ ! nearest neighbor sub-levels
+!
+! Output Arguments
+!
+ real(r8), intent(out) :: abstrc(pcols) ! total trace gas absorptivity
+
+!
+!--------------------------Local Variables------------------------------
+!
+ integer i,l ! loop counters
+!
+ real(r8) sqti(pcols) ! square root of mean temp
+ real(r8) rsqti(pcols) ! reciprocal of sqti
+ real(r8) du1 ! cfc11 path length
+ real(r8) du2 ! cfc12 path length
+ real(r8) acfc1 ! absorptivity of cfc11 798 cm-1 band
+!
+ real(r8) acfc2 ! absorptivity of cfc11 846 cm-1 band
+ real(r8) acfc3 ! absorptivity of cfc11 933 cm-1 band
+ real(r8) acfc4 ! absorptivity of cfc11 1085 cm-1 band
+ real(r8) acfc5 ! absorptivity of cfc11 889 cm-1 band
+ real(r8) acfc6 ! absorptivity of cfc11 923 cm-1 band
+!
+ real(r8) acfc7 ! absorptivity of cfc11 1102 cm-1 band
+ real(r8) acfc8 ! absorptivity of cfc11 1161 cm-1 band
+ real(r8) du01 ! n2o path length
+ real(r8) dbeta01 ! n2o pressure factors
+ real(r8) dbeta11 ! "
+!
+ real(r8) an2o1 ! absorptivity of the 1285 cm-1 n2o band
+ real(r8) du02 ! n2o path length
+ real(r8) dbeta02 ! n2o pressure factor
+ real(r8) an2o2 ! absorptivity of the 589 cm-1 n2o band
+ real(r8) du03 ! n2o path length
+!
+ real(r8) dbeta03 ! n2o pressure factor
+ real(r8) an2o3 ! absorptivity of the 1168 cm-1 n2o band
+ real(r8) duch4 ! ch4 path length
+ real(r8) dbetac ! ch4 pressure factor
+ real(r8) ach4 ! absorptivity of the 1306 cm-1 ch4 band
+!
+ real(r8) du11 ! co2 path length
+ real(r8) du12 ! "
+ real(r8) du13 ! "
+ real(r8) dbetc1 ! co2 pressure factor
+ real(r8) dbetc2 ! co2 pressure factor
+!
+ real(r8) aco21 ! absorptivity of the 1064 cm-1 co2 band
+ real(r8) du21 ! co2 path length
+ real(r8) du22 ! "
+ real(r8) du23 ! "
+ real(r8) aco22 ! absorptivity of the 961 cm-1 co2 band
+!
+ real(r8) tt(pcols) ! temp. factor for h2o overlap
+ real(r8) psi1 ! "
+ real(r8) phi1 ! "
+ real(r8) p1 ! factor for h2o overlap
+ real(r8) w1 ! "
+!
+ real(r8) ds2c(pcols) ! continuum path length
+ real(r8) duptyp(pcols) ! p-type path length
+ real(r8) tw(pcols,6) ! h2o transmission overlap
+ real(r8) g1(6) ! h2o overlap factor
+ real(r8) g2(6) ! "
+!
+ real(r8) g3(6) ! "
+ real(r8) g4(6) ! "
+ real(r8) ab(6) ! h2o temp. factor
+ real(r8) bb(6) ! "
+ real(r8) abp(6) ! "
+!
+ real(r8) bbp(6) ! "
+ real(r8) tcfc3 ! transmission of cfc11 band
+ real(r8) tcfc4 ! transmission of cfc11 band
+ real(r8) tcfc6 ! transmission of cfc12 band
+ real(r8) tcfc7 ! "
+!
+ real(r8) tcfc8 ! "
+ real(r8) tlw ! h2o transmission
+ real(r8) tch4 ! ch4 transmission
+!
+!--------------------------Data Statements------------------------------
+!
+ data g1 /0.0468556,0.0397454,0.0407664,0.0304380,0.0540398,0.0321962/
+ data g2 /14.4832,4.30242,5.23523,3.25342,0.698935,16.5599/
+ data g3 /26.1898,18.4476,15.3633,12.1927,9.14992,8.07092/
+ data g4 /0.0261782,0.0369516,0.0307266,0.0243854,0.0182932,0.0161418/
+ data ab /3.0857e-2,2.3524e-2,1.7310e-2,2.6661e-2,2.8074e-2,2.2915e-2/
+ data bb /-1.3512e-4,-6.8320e-5,-3.2609e-5,-1.0228e-5,-9.5743e-5,-1.0304e-4/
+ data abp/2.9129e-2,2.4101e-2,1.9821e-2,2.6904e-2,2.9458e-2,1.9892e-2/
+ data bbp/-1.3139e-4,-5.5688e-5,-4.6380e-5,-8.0362e-5,-1.0115e-4,-8.8061e-5/
+!
+!--------------------------Statement Functions--------------------------
+!
+ real(r8) func, u, b
+ func(u,b) = u/sqrt(4.0 + u*(1.0 + 1.0 / b))
+!
+!------------------------------------------------------------------
+!
+ do i = 1,ncol
+ sqti(i) = sqrt(tbar(i,kn))
+ rsqti(i) = 1. / sqti(i)
+!
+! h2o transmission
+!
+ tt(i) = abs(tbar(i,kn) - 250.0)
+ ds2c(i) = abs(s2c(i,k2+1) - s2c(i,k2))*uinpl(i,kn)
+ duptyp(i) = abs(uptype(i,k2+1) - uptype(i,k2))*uinpl(i,kn)
+ end do
+!
+ do l = 1,6
+ do i = 1,ncol
+ psi1 = exp(abp(l)*tt(i)+bbp(l)*tt(i)*tt(i))
+ phi1 = exp(ab(l)*tt(i)+bb(l)*tt(i)*tt(i))
+ p1 = pnew(i) * (psi1/phi1) / sslp
+ w1 = dw(i) * winpl(i,kn) * phi1
+ tw(i,l) = exp(- g1(l)*p1*(sqrt(1.0+g2(l)*(w1/p1))-1.0) &
+ - g3(l)*ds2c(i)-g4(l)*duptyp(i))
+ end do
+ end do
+!
+ do i=1,ncol
+ tw(i,1)=tw(i,1)*(0.7*aer_trn_ngh(i,idx_LW_0650_0800)+&! l=1: 0750--0820 cm-1
+ 0.3*aer_trn_ngh(i,idx_LW_0800_1000))
+ tw(i,2)=tw(i,2)*aer_trn_ngh(i,idx_LW_0800_1000) ! l=2: 0820--0880 cm-1
+ tw(i,3)=tw(i,3)*aer_trn_ngh(i,idx_LW_0800_1000) ! l=3: 0880--0900 cm-1
+ tw(i,4)=tw(i,4)*aer_trn_ngh(i,idx_LW_0800_1000) ! l=4: 0900--1000 cm-1
+ tw(i,5)=tw(i,5)*aer_trn_ngh(i,idx_LW_1000_1200) ! l=5: 1000--1120 cm-1
+ tw(i,6)=tw(i,6)*aer_trn_ngh(i,idx_LW_1000_1200) ! l=6: 1120--1170 cm-1
+ end do ! end loop over lon
+
+ do i = 1,ncol
+!
+ du1 = abs(ucfc11(i,k2+1) - ucfc11(i,k2)) * winpl(i,kn)
+ du2 = abs(ucfc12(i,k2+1) - ucfc12(i,k2)) * winpl(i,kn)
+!
+! cfc transmissions
+!
+ tcfc3 = exp(-175.005*du1)
+ tcfc4 = exp(-1202.18*du1)
+ tcfc6 = exp(-5786.73*du2)
+ tcfc7 = exp(-2873.51*du2)
+ tcfc8 = exp(-2085.59*du2)
+!
+! Absorptivity for CFC11 bands
+!
+ acfc1 = 50.0*(1.0 - exp(-54.09*du1)) * tw(i,1)*bplnk(7,i,kn)
+ acfc2 = 60.0*(1.0 - exp(-5130.03*du1))*tw(i,2)*bplnk(8,i,kn)
+ acfc3 = 60.0*(1.0 - tcfc3)*tw(i,4)*tcfc6 * bplnk(9,i,kn)
+ acfc4 = 100.0*(1.0 - tcfc4)* tw(i,5) * bplnk(10,i,kn)
+!
+! Absorptivity for CFC12 bands
+!
+ acfc5 = 45.0*(1.0 - exp(-1272.35*du2))*tw(i,3)*bplnk(11,i,kn)
+ acfc6 = 50.0*(1.0 - tcfc6)*tw(i,4)*bplnk(12,i,kn)
+ acfc7 = 80.0*(1.0 - tcfc7)* tw(i,5)*tcfc4 *bplnk(13,i,kn)
+ acfc8 = 70.0*(1.0 - tcfc8)*tw(i,6)*bplnk(14,i,kn)
+!
+! Absorptivity for CH4 band 1306 cm-1
+!
+ tlw = exp(-1.0*sqrt(up2(i)))
+ tlw=tlw*aer_trn_ngh(i,idx_LW_1200_2000)
+ duch4 = abs(uch4(i,k2+1) - uch4(i,k2)) * winpl(i,kn)
+ dbetac = 2.94449 * pinpl(i,kn) * rsqti(i) / sslp
+ ach4 = 6.00444*sqti(i)*log(1.0 + func(duch4,dbetac)) * tlw * bplnk(3,i,kn)
+ tch4 = 1.0/(1.0 + 0.02*func(duch4,dbetac))
+!
+! Absorptivity for N2O bands
+!
+ du01 = abs(un2o0(i,k2+1) - un2o0(i,k2)) * winpl(i,kn)
+ du11 = abs(un2o1(i,k2+1) - un2o1(i,k2)) * winpl(i,kn)
+ dbeta01 = 19.399 * pinpl(i,kn) * rsqti(i) / sslp
+ dbeta11 = dbeta01
+!
+! 1285 cm-1 band
+!
+ an2o1 = 2.35558*sqti(i)*log(1.0 + func(du01,dbeta01) &
+ + func(du11,dbeta11)) * tlw * tch4 * bplnk(4,i,kn)
+ du02 = 0.100090*du01
+ du12 = 0.0992746*du11
+ dbeta02 = 0.964282*dbeta01
+!
+! 589 cm-1 band
+!
+ an2o2 = 2.65581*sqti(i)*log(1.0 + func(du02,dbeta02) &
+ + func(du12,dbeta02)) * tco2(i) * th2o(i) * bplnk(5,i,kn)
+ du03 = 0.0333767*du01
+ dbeta03 = 0.982143*dbeta01
+!
+! 1168 cm-1 band
+!
+ an2o3 = 2.54034*sqti(i)*log(1.0 + func(du03,dbeta03)) * &
+ tw(i,6) * tcfc8 * bplnk(6,i,kn)
+!
+! Absorptivity for 1064 cm-1 band of CO2
+!
+ du11 = abs(uco211(i,k2+1) - uco211(i,k2)) * winpl(i,kn)
+ du12 = abs(uco212(i,k2+1) - uco212(i,k2)) * winpl(i,kn)
+ du13 = abs(uco213(i,k2+1) - uco213(i,k2)) * winpl(i,kn)
+ dbetc1 = 2.97558 * pinpl(i,kn) * rsqti(i) / sslp
+ dbetc2 = 2.0 * dbetc1
+ aco21 = 3.7571*sqti(i)*log(1.0 + func(du11,dbetc1) &
+ + func(du12,dbetc2) + func(du13,dbetc2)) &
+ * to3(i) * tw(i,5) * tcfc4 * tcfc7 * bplnk(2,i,kn)
+!
+! Absorptivity for 961 cm-1 band of co2
+!
+ du21 = abs(uco221(i,k2+1) - uco221(i,k2)) * winpl(i,kn)
+ du22 = abs(uco222(i,k2+1) - uco222(i,k2)) * winpl(i,kn)
+ du23 = abs(uco223(i,k2+1) - uco223(i,k2)) * winpl(i,kn)
+ aco22 = 3.8443*sqti(i)*log(1.0 + func(du21,dbetc1) &
+ + func(du22,dbetc1) + func(du23,dbetc2)) &
+ * tw(i,4) * tcfc3 * tcfc6 * bplnk(1,i,kn)
+!
+! total trace gas absorptivity
+!
+ abstrc(i) = acfc1 + acfc2 + acfc3 + acfc4 + acfc5 + acfc6 + &
+ acfc7 + acfc8 + an2o1 + an2o2 + an2o3 + ach4 + &
+ aco21 + aco22
+ end do
+!
+ return
+!
+end subroutine trcabn
+
+
+
+subroutine trcems(lchnk ,ncol ,pcols, pverp, &
+ k ,co2t ,pnm ,ucfc11 ,ucfc12 , &
+ un2o0 ,un2o1 ,bn2o0 ,bn2o1 ,uch4 , &
+ bch4 ,uco211 ,uco212 ,uco213 ,uco221 , &
+ uco222 ,uco223 ,uptype ,w ,s2c , &
+ up2 ,emplnk ,th2o ,tco2 ,to3 , &
+ emstrc , &
+ aer_trn_ttl)
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Calculate emissivity for CH4, N2O, CFC11 and CFC12 bands.
+!
+! Method:
+! See CCM3 Description for equations.
+!
+! Author: J. Kiehl
+!
+!-----------------------------------------------------------------------
+! use shr_kind_mod, only: r8 => shr_kind_r8
+! use ppgrid
+! use volcrad
+
+ implicit none
+
+!
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+ integer, intent(in) :: lchnk ! chunk identifier
+ integer, intent(in) :: ncol ! number of atmospheric columns
+ integer, intent(in) :: pcols, pverp
+
+ real(r8), intent(in) :: co2t(pcols,pverp) ! pressure weighted temperature
+ real(r8), intent(in) :: pnm(pcols,pverp) ! interface pressure
+ real(r8), intent(in) :: ucfc11(pcols,pverp) ! CFC11 path length
+ real(r8), intent(in) :: ucfc12(pcols,pverp) ! CFC12 path length
+ real(r8), intent(in) :: un2o0(pcols,pverp) ! N2O path length
+!
+ real(r8), intent(in) :: un2o1(pcols,pverp) ! N2O path length (hot band)
+ real(r8), intent(in) :: uch4(pcols,pverp) ! CH4 path length
+ real(r8), intent(in) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length
+ real(r8), intent(in) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length
+ real(r8), intent(in) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length
+!
+ real(r8), intent(in) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length
+ real(r8), intent(in) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length
+ real(r8), intent(in) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length
+ real(r8), intent(in) :: uptype(pcols,pverp) ! continuum path length
+ real(r8), intent(in) :: bn2o0(pcols,pverp) ! pressure factor for n2o
+!
+ real(r8), intent(in) :: bn2o1(pcols,pverp) ! pressure factor for n2o
+ real(r8), intent(in) :: bch4(pcols,pverp) ! pressure factor for ch4
+ real(r8), intent(in) :: emplnk(14,pcols) ! emissivity Planck factor
+ real(r8), intent(in) :: th2o(pcols) ! water vapor overlap factor
+ real(r8), intent(in) :: tco2(pcols) ! co2 overlap factor
+!
+ real(r8), intent(in) :: to3(pcols) ! o3 overlap factor
+ real(r8), intent(in) :: s2c(pcols,pverp) ! h2o continuum path length
+ real(r8), intent(in) :: w(pcols,pverp) ! h2o path length
+ real(r8), intent(in) :: up2(pcols) ! pressure squared h2o path length
+!
+ integer, intent(in) :: k ! level index
+
+ real(r8), intent(in) :: aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! aer trn.
+
+!
+! Output Arguments
+!
+ real(r8), intent(out) :: emstrc(pcols,pverp) ! total trace gas emissivity
+
+!
+!--------------------------Local Variables------------------------------
+!
+ integer i,l ! loop counters
+!
+ real(r8) sqti(pcols) ! square root of mean temp
+ real(r8) ecfc1 ! emissivity of cfc11 798 cm-1 band
+ real(r8) ecfc2 ! " " " 846 cm-1 band
+ real(r8) ecfc3 ! " " " 933 cm-1 band
+ real(r8) ecfc4 ! " " " 1085 cm-1 band
+!
+ real(r8) ecfc5 ! " " cfc12 889 cm-1 band
+ real(r8) ecfc6 ! " " " 923 cm-1 band
+ real(r8) ecfc7 ! " " " 1102 cm-1 band
+ real(r8) ecfc8 ! " " " 1161 cm-1 band
+ real(r8) u01 ! n2o path length
+!
+ real(r8) u11 ! n2o path length
+ real(r8) beta01 ! n2o pressure factor
+ real(r8) beta11 ! n2o pressure factor
+ real(r8) en2o1 ! emissivity of the 1285 cm-1 N2O band
+ real(r8) u02 ! n2o path length
+!
+ real(r8) u12 ! n2o path length
+ real(r8) beta02 ! n2o pressure factor
+ real(r8) en2o2 ! emissivity of the 589 cm-1 N2O band
+ real(r8) u03 ! n2o path length
+ real(r8) beta03 ! n2o pressure factor
+!
+ real(r8) en2o3 ! emissivity of the 1168 cm-1 N2O band
+ real(r8) betac ! ch4 pressure factor
+ real(r8) ech4 ! emissivity of 1306 cm-1 CH4 band
+ real(r8) betac1 ! co2 pressure factor
+ real(r8) betac2 ! co2 pressure factor
+!
+ real(r8) eco21 ! emissivity of 1064 cm-1 CO2 band
+ real(r8) eco22 ! emissivity of 961 cm-1 CO2 band
+ real(r8) tt(pcols) ! temp. factor for h2o overlap factor
+ real(r8) psi1 ! narrow band h2o temp. factor
+ real(r8) phi1 ! "
+!
+ real(r8) p1 ! h2o line overlap factor
+ real(r8) w1 ! "
+ real(r8) tw(pcols,6) ! h2o transmission overlap
+ real(r8) g1(6) ! h2o overlap factor
+ real(r8) g2(6) ! "
+!
+ real(r8) g3(6) ! "
+ real(r8) g4(6) ! "
+ real(r8) ab(6) ! "
+ real(r8) bb(6) ! "
+ real(r8) abp(6) ! "
+!
+ real(r8) bbp(6) ! "
+ real(r8) tcfc3 ! transmission for cfc11 band
+ real(r8) tcfc4 ! "
+ real(r8) tcfc6 ! transmission for cfc12 band
+ real(r8) tcfc7 ! "
+!
+ real(r8) tcfc8 ! "
+ real(r8) tlw ! h2o overlap factor
+ real(r8) tch4 ! ch4 overlap factor
+!
+!--------------------------Data Statements------------------------------
+!
+ data g1 /0.0468556,0.0397454,0.0407664,0.0304380,0.0540398,0.0321962/
+ data g2 /14.4832,4.30242,5.23523,3.25342,0.698935,16.5599/
+ data g3 /26.1898,18.4476,15.3633,12.1927,9.14992,8.07092/
+ data g4 /0.0261782,0.0369516,0.0307266,0.0243854,0.0182932,0.0161418/
+ data ab /3.0857e-2,2.3524e-2,1.7310e-2,2.6661e-2,2.8074e-2,2.2915e-2/
+ data bb /-1.3512e-4,-6.8320e-5,-3.2609e-5,-1.0228e-5,-9.5743e-5,-1.0304e-4/
+ data abp/2.9129e-2,2.4101e-2,1.9821e-2,2.6904e-2,2.9458e-2,1.9892e-2/
+ data bbp/-1.3139e-4,-5.5688e-5,-4.6380e-5,-8.0362e-5,-1.0115e-4,-8.8061e-5/
+!
+!--------------------------Statement Functions--------------------------
+!
+ real(r8) func, u, b
+ func(u,b) = u/sqrt(4.0 + u*(1.0 + 1.0 / b))
+!
+!-----------------------------------------------------------------------
+!
+ do i = 1,ncol
+ sqti(i) = sqrt(co2t(i,k))
+!
+! Transmission for h2o
+!
+ tt(i) = abs(co2t(i,k) - 250.0)
+ end do
+!
+ do l = 1,6
+ do i = 1,ncol
+ psi1 = exp(abp(l)*tt(i)+bbp(l)*tt(i)*tt(i))
+ phi1 = exp(ab(l)*tt(i)+bb(l)*tt(i)*tt(i))
+ p1 = pnm(i,k) * (psi1/phi1) / sslp
+ w1 = w(i,k) * phi1
+ tw(i,l) = exp(- g1(l)*p1*(sqrt(1.0+g2(l)*(w1/p1))-1.0) &
+ - g3(l)*s2c(i,k)-g4(l)*uptype(i,k))
+ end do
+ end do
+
+! Overlap H2O tranmission with STRAER continuum in 6 trace gas
+! subbands
+
+ do i=1,ncol
+ tw(i,1)=tw(i,1)*(0.7*aer_trn_ttl(i,k,1,idx_LW_0650_0800)+&! l=1: 0750--0820 cm-1
+ 0.3*aer_trn_ttl(i,k,1,idx_LW_0800_1000))
+ tw(i,2)=tw(i,2)*aer_trn_ttl(i,k,1,idx_LW_0800_1000) ! l=2: 0820--0880 cm-1
+ tw(i,3)=tw(i,3)*aer_trn_ttl(i,k,1,idx_LW_0800_1000) ! l=3: 0880--0900 cm-1
+ tw(i,4)=tw(i,4)*aer_trn_ttl(i,k,1,idx_LW_0800_1000) ! l=4: 0900--1000 cm-1
+ tw(i,5)=tw(i,5)*aer_trn_ttl(i,k,1,idx_LW_1000_1200) ! l=5: 1000--1120 cm-1
+ tw(i,6)=tw(i,6)*aer_trn_ttl(i,k,1,idx_LW_1000_1200) ! l=6: 1120--1170 cm-1
+ end do ! end loop over lon
+!
+ do i = 1,ncol
+!
+! transmission due to cfc bands
+!
+ tcfc3 = exp(-175.005*ucfc11(i,k))
+ tcfc4 = exp(-1202.18*ucfc11(i,k))
+ tcfc6 = exp(-5786.73*ucfc12(i,k))
+ tcfc7 = exp(-2873.51*ucfc12(i,k))
+ tcfc8 = exp(-2085.59*ucfc12(i,k))
+!
+! Emissivity for CFC11 bands
+!
+ ecfc1 = 50.0*(1.0 - exp(-54.09*ucfc11(i,k))) * tw(i,1) * emplnk(7,i)
+ ecfc2 = 60.0*(1.0 - exp(-5130.03*ucfc11(i,k)))* tw(i,2) * emplnk(8,i)
+ ecfc3 = 60.0*(1.0 - tcfc3)*tw(i,4)*tcfc6*emplnk(9,i)
+ ecfc4 = 100.0*(1.0 - tcfc4)*tw(i,5)*emplnk(10,i)
+!
+! Emissivity for CFC12 bands
+!
+ ecfc5 = 45.0*(1.0 - exp(-1272.35*ucfc12(i,k)))*tw(i,3)*emplnk(11,i)
+ ecfc6 = 50.0*(1.0 - tcfc6)*tw(i,4)*emplnk(12,i)
+ ecfc7 = 80.0*(1.0 - tcfc7)*tw(i,5)* tcfc4 * emplnk(13,i)
+ ecfc8 = 70.0*(1.0 - tcfc8)*tw(i,6) * emplnk(14,i)
+!
+! Emissivity for CH4 band 1306 cm-1
+!
+ tlw = exp(-1.0*sqrt(up2(i)))
+
+! Overlap H2O vibration rotation band with STRAER continuum
+! for CH4 1306 cm-1 and N2O 1285 cm-1 bands
+
+ tlw=tlw*aer_trn_ttl(i,k,1,idx_LW_1200_2000)
+ betac = bch4(i,k)/uch4(i,k)
+ ech4 = 6.00444*sqti(i)*log(1.0 + func(uch4(i,k),betac)) *tlw * emplnk(3,i)
+ tch4 = 1.0/(1.0 + 0.02*func(uch4(i,k),betac))
+!
+! Emissivity for N2O bands
+!
+ u01 = un2o0(i,k)
+ u11 = un2o1(i,k)
+ beta01 = bn2o0(i,k)/un2o0(i,k)
+ beta11 = bn2o1(i,k)/un2o1(i,k)
+!
+! 1285 cm-1 band
+!
+ en2o1 = 2.35558*sqti(i)*log(1.0 + func(u01,beta01) + &
+ func(u11,beta11))*tlw*tch4*emplnk(4,i)
+ u02 = 0.100090*u01
+ u12 = 0.0992746*u11
+ beta02 = 0.964282*beta01
+!
+! 589 cm-1 band
+!
+ en2o2 = 2.65581*sqti(i)*log(1.0 + func(u02,beta02) + &
+ func(u12,beta02)) * tco2(i) * th2o(i) * emplnk(5,i)
+ u03 = 0.0333767*u01
+ beta03 = 0.982143*beta01
+!
+! 1168 cm-1 band
+!
+ en2o3 = 2.54034*sqti(i)*log(1.0 + func(u03,beta03)) * &
+ tw(i,6) * tcfc8 * emplnk(6,i)
+!
+! Emissivity for 1064 cm-1 band of CO2
+!
+ betac1 = 2.97558*pnm(i,k) / (sslp*sqti(i))
+ betac2 = 2.0 * betac1
+ eco21 = 3.7571*sqti(i)*log(1.0 + func(uco211(i,k),betac1) &
+ + func(uco212(i,k),betac2) + func(uco213(i,k),betac2)) &
+ * to3(i) * tw(i,5) * tcfc4 * tcfc7 * emplnk(2,i)
+!
+! Emissivity for 961 cm-1 band
+!
+ eco22 = 3.8443*sqti(i)*log(1.0 + func(uco221(i,k),betac1) &
+ + func(uco222(i,k),betac1) + func(uco223(i,k),betac2)) &
+ * tw(i,4) * tcfc3 * tcfc6 * emplnk(1,i)
+!
+! total trace gas emissivity
+!
+ emstrc(i,k) = ecfc1 + ecfc2 + ecfc3 + ecfc4 + ecfc5 +ecfc6 + &
+ ecfc7 + ecfc8 + en2o1 + en2o2 + en2o3 + ech4 + &
+ eco21 + eco22
+ end do
+!
+ return
+!
+end subroutine trcems
+
+subroutine trcmix(lchnk ,ncol ,pcols, pver, &
+ pmid ,clat, n2o ,ch4 , &
+ cfc11 , cfc12 )
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Specify zonal mean mass mixing ratios of CH4, N2O, CFC11 and
+! CFC12
+!
+! Method:
+! Distributions assume constant mixing ratio in the troposphere
+! and a decrease of mixing ratio in the stratosphere. Tropopause
+! defined by ptrop. The scale height of the particular trace gas
+! depends on latitude. This assumption produces a more realistic
+! stratospheric distribution of the various trace gases.
+!
+! Author: J. Kiehl
+!
+!-----------------------------------------------------------------------
+! use shr_kind_mod, only: r8 => shr_kind_r8
+! use ppgrid
+! use phys_grid, only: get_rlat_all_p
+! use physconst, only: mwdry, mwch4, mwn2o, mwf11, mwf12
+! use ghg_surfvals, only: ch4vmr, n2ovmr, f11vmr, f12vmr
+
+ implicit none
+
+!-----------------------------Arguments---------------------------------
+!
+! Input
+!
+ integer, intent(in) :: lchnk ! chunk identifier
+ integer, intent(in) :: ncol ! number of atmospheric columns
+ integer, intent(in) :: pcols, pver
+
+ real(r8), intent(in) :: pmid(pcols,pver) ! model pressures
+ real(r8), intent(in) :: clat(pcols) ! latitude in radians for columns
+!
+! Output
+!
+ real(r8), intent(out) :: n2o(pcols,pver) ! nitrous oxide mass mixing ratio
+ real(r8), intent(out) :: ch4(pcols,pver) ! methane mass mixing ratio
+ real(r8), intent(out) :: cfc11(pcols,pver) ! cfc11 mass mixing ratio
+ real(r8), intent(out) :: cfc12(pcols,pver) ! cfc12 mass mixing ratio
+
+!
+!--------------------------Local Variables------------------------------
+
+ real(r8) :: rmwn2o ! ratio of molecular weight n2o to dry air
+ real(r8) :: rmwch4 ! ratio of molecular weight ch4 to dry air
+ real(r8) :: rmwf11 ! ratio of molecular weight cfc11 to dry air
+ real(r8) :: rmwf12 ! ratio of molecular weight cfc12 to dry air
+!
+ integer i ! longitude loop index
+ integer k ! level index
+!
+! real(r8) clat(pcols) ! latitude in radians for columns
+ real(r8) coslat(pcols) ! cosine of latitude
+ real(r8) dlat ! latitude in degrees
+ real(r8) ptrop ! pressure level of tropopause
+ real(r8) pratio ! pressure divided by ptrop
+!
+ real(r8) xn2o ! pressure scale height for n2o
+ real(r8) xch4 ! pressure scale height for ch4
+ real(r8) xcfc11 ! pressure scale height for cfc11
+ real(r8) xcfc12 ! pressure scale height for cfc12
+!
+ real(r8) ch40 ! tropospheric mass mixing ratio for ch4
+ real(r8) n2o0 ! tropospheric mass mixing ratio for n2o
+ real(r8) cfc110 ! tropospheric mass mixing ratio for cfc11
+ real(r8) cfc120 ! tropospheric mass mixing ratio for cfc12
+!
+!-----------------------------------------------------------------------
+ rmwn2o = mwn2o/mwdry ! ratio of molecular weight n2o to dry air
+ rmwch4 = mwch4/mwdry ! ratio of molecular weight ch4 to dry air
+ rmwf11 = mwf11/mwdry ! ratio of molecular weight cfc11 to dry air
+ rmwf12 = mwf12/mwdry ! ratio of molecular weight cfc12 to dry air
+!
+! get latitudes
+!
+! call get_rlat_all_p(lchnk, ncol, clat)
+ do i = 1, ncol
+ coslat(i) = cos(clat(i))
+ end do
+!
+! set tropospheric mass mixing ratios
+!
+ ch40 = rmwch4 * ch4vmr
+ n2o0 = rmwn2o * n2ovmr
+ cfc110 = rmwf11 * f11vmr
+ cfc120 = rmwf12 * f12vmr
+
+ do i = 1, ncol
+ coslat(i) = cos(clat(i))
+ end do
+!
+ do k = 1,pver
+ do i = 1,ncol
+!
+! set stratospheric scale height factor for gases
+ dlat = abs(57.2958 * clat(i))
+ if(dlat.le.45.0) then
+ xn2o = 0.3478 + 0.00116 * dlat
+ xch4 = 0.2353
+ xcfc11 = 0.7273 + 0.00606 * dlat
+ xcfc12 = 0.4000 + 0.00222 * dlat
+ else
+ xn2o = 0.4000 + 0.013333 * (dlat - 45)
+ xch4 = 0.2353 + 0.0225489 * (dlat - 45)
+ xcfc11 = 1.00 + 0.013333 * (dlat - 45)
+ xcfc12 = 0.50 + 0.024444 * (dlat - 45)
+ end if
+!
+! pressure of tropopause
+ ptrop = 250.0e2 - 150.0e2*coslat(i)**2.0
+!
+! determine output mass mixing ratios
+ if (pmid(i,k) >= ptrop) then
+ ch4(i,k) = ch40
+ n2o(i,k) = n2o0
+ cfc11(i,k) = cfc110
+ cfc12(i,k) = cfc120
+ else
+ pratio = pmid(i,k)/ptrop
+ ch4(i,k) = ch40 * (pratio)**xch4
+ n2o(i,k) = n2o0 * (pratio)**xn2o
+ cfc11(i,k) = cfc110 * (pratio)**xcfc11
+ cfc12(i,k) = cfc120 * (pratio)**xcfc12
+ end if
+ end do
+ end do
+!
+ return
+!
+end subroutine trcmix
+
+subroutine trcplk(lchnk ,ncol ,pcols, pver, pverp, &
+ tint ,tlayr ,tplnke ,emplnk ,abplnk1 , &
+ abplnk2 )
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Calculate Planck factors for absorptivity and emissivity of
+! CH4, N2O, CFC11 and CFC12
+!
+! Method:
+! Planck function and derivative evaluated at the band center.
+!
+! Author: J. Kiehl
+!
+!-----------------------------------------------------------------------
+! use shr_kind_mod, only: r8 => shr_kind_r8
+! use ppgrid
+
+ implicit none
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+ integer, intent(in) :: lchnk ! chunk identifier
+ integer, intent(in) :: ncol ! number of atmospheric columns
+ integer, intent(in) :: pcols, pver, pverp
+
+ real(r8), intent(in) :: tint(pcols,pverp) ! interface temperatures
+ real(r8), intent(in) :: tlayr(pcols,pverp) ! k-1 level temperatures
+ real(r8), intent(in) :: tplnke(pcols) ! Top Layer temperature
+!
+! output arguments
+!
+ real(r8), intent(out) :: emplnk(14,pcols) ! emissivity Planck factor
+ real(r8), intent(out) :: abplnk1(14,pcols,pverp) ! non-nearest layer Plack factor
+ real(r8), intent(out) :: abplnk2(14,pcols,pverp) ! nearest layer factor
+
+!
+!--------------------------Local Variables------------------------------
+!
+ integer wvl ! wavelength index
+ integer i,k ! loop counters
+!
+ real(r8) f1(14) ! Planck function factor
+ real(r8) f2(14) ! "
+ real(r8) f3(14) ! "
+!
+!--------------------------Data Statements------------------------------
+!
+ data f1 /5.85713e8,7.94950e8,1.47009e9,1.40031e9,1.34853e8, &
+ 1.05158e9,3.35370e8,3.99601e8,5.35994e8,8.42955e8, &
+ 4.63682e8,5.18944e8,8.83202e8,1.03279e9/
+ data f2 /2.02493e11,3.04286e11,6.90698e11,6.47333e11, &
+ 2.85744e10,4.41862e11,9.62780e10,1.21618e11, &
+ 1.79905e11,3.29029e11,1.48294e11,1.72315e11, &
+ 3.50140e11,4.31364e11/
+ data f3 /1383.0,1531.0,1879.0,1849.0,848.0,1681.0, &
+ 1148.0,1217.0,1343.0,1561.0,1279.0,1328.0, &
+ 1586.0,1671.0/
+!
+!-----------------------------------------------------------------------
+!
+! Calculate emissivity Planck factor
+!
+ do wvl = 1,14
+ do i = 1,ncol
+ emplnk(wvl,i) = f1(wvl)/(tplnke(i)**4.0*(exp(f3(wvl)/tplnke(i))-1.0))
+ end do
+ end do
+!
+! Calculate absorptivity Planck factor for tint and tlayr temperatures
+!
+ do wvl = 1,14
+ do k = ntoplw, pverp
+ do i = 1, ncol
+!
+! non-nearlest layer function
+!
+ abplnk1(wvl,i,k) = (f2(wvl)*exp(f3(wvl)/tint(i,k))) &
+ /(tint(i,k)**5.0*(exp(f3(wvl)/tint(i,k))-1.0)**2.0)
+!
+! nearest layer function
+!
+ abplnk2(wvl,i,k) = (f2(wvl)*exp(f3(wvl)/tlayr(i,k))) &
+ /(tlayr(i,k)**5.0*(exp(f3(wvl)/tlayr(i,k))-1.0)**2.0)
+ end do
+ end do
+ end do
+!
+ return
+end subroutine trcplk
+
+subroutine trcpth(lchnk ,ncol ,pcols, pver, pverp, &
+ tnm ,pnm ,cfc11 ,cfc12 ,n2o , &
+ ch4 ,qnm ,ucfc11 ,ucfc12 ,un2o0 , &
+ un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , &
+ uco221 ,uco222 ,uco223 ,bn2o0 ,bn2o1 , &
+ bch4 ,uptype )
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Calculate path lengths and pressure factors for CH4, N2O, CFC11
+! and CFC12.
+!
+! Method:
+! See CCM3 description for details
+!
+! Author: J. Kiehl
+!
+!-----------------------------------------------------------------------
+! use shr_kind_mod, only: r8 => shr_kind_r8
+! use ppgrid
+! use ghg_surfvals, only: co2mmr
+
+ implicit none
+
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+ integer, intent(in) :: lchnk ! chunk identifier
+ integer, intent(in) :: ncol ! number of atmospheric columns
+ integer, intent(in) :: pcols, pver, pverp
+
+ real(r8), intent(in) :: tnm(pcols,pver) ! Model level temperatures
+ real(r8), intent(in) :: pnm(pcols,pverp) ! Pres. at model interfaces (dynes/cm2)
+ real(r8), intent(in) :: qnm(pcols,pver) ! h2o specific humidity
+ real(r8), intent(in) :: cfc11(pcols,pver) ! CFC11 mass mixing ratio
+!
+ real(r8), intent(in) :: cfc12(pcols,pver) ! CFC12 mass mixing ratio
+ real(r8), intent(in) :: n2o(pcols,pver) ! N2O mass mixing ratio
+ real(r8), intent(in) :: ch4(pcols,pver) ! CH4 mass mixing ratio
+
+!
+! Output arguments
+!
+ real(r8), intent(out) :: ucfc11(pcols,pverp) ! CFC11 path length
+ real(r8), intent(out) :: ucfc12(pcols,pverp) ! CFC12 path length
+ real(r8), intent(out) :: un2o0(pcols,pverp) ! N2O path length
+ real(r8), intent(out) :: un2o1(pcols,pverp) ! N2O path length (hot band)
+ real(r8), intent(out) :: uch4(pcols,pverp) ! CH4 path length
+!
+ real(r8), intent(out) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length
+ real(r8), intent(out) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length
+ real(r8), intent(out) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length
+ real(r8), intent(out) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length
+ real(r8), intent(out) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length
+!
+ real(r8), intent(out) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length
+ real(r8), intent(out) :: bn2o0(pcols,pverp) ! pressure factor for n2o
+ real(r8), intent(out) :: bn2o1(pcols,pverp) ! pressure factor for n2o
+ real(r8), intent(out) :: bch4(pcols,pverp) ! pressure factor for ch4
+ real(r8), intent(out) :: uptype(pcols,pverp) ! p-type continuum path length
+
+!
+!---------------------------Local variables-----------------------------
+!
+ integer i ! Longitude index
+ integer k ! Level index
+!
+ real(r8) co2fac(pcols,1) ! co2 factor
+ real(r8) alpha1(pcols) ! stimulated emission term
+ real(r8) alpha2(pcols) ! stimulated emission term
+ real(r8) rt(pcols) ! reciprocal of local temperature
+ real(r8) rsqrt(pcols) ! reciprocal of sqrt of temp
+!
+ real(r8) pbar(pcols) ! mean pressure
+ real(r8) dpnm(pcols) ! difference in pressure
+ real(r8) diff ! diffusivity factor
+!
+!--------------------------Data Statements------------------------------
+!
+ data diff /1.66/
+!
+!-----------------------------------------------------------------------
+!
+! Calculate path lengths for the trace gases at model top
+!
+ do i = 1,ncol
+ ucfc11(i,ntoplw) = 1.8 * cfc11(i,ntoplw) * pnm(i,ntoplw) * rga
+ ucfc12(i,ntoplw) = 1.8 * cfc12(i,ntoplw) * pnm(i,ntoplw) * rga
+ un2o0(i,ntoplw) = diff * 1.02346e5 * n2o(i,ntoplw) * pnm(i,ntoplw) * rga / sqrt(tnm(i,ntoplw))
+ un2o1(i,ntoplw) = diff * 2.01909 * un2o0(i,ntoplw) * exp(-847.36/tnm(i,ntoplw))
+ uch4(i,ntoplw) = diff * 8.60957e4 * ch4(i,ntoplw) * pnm(i,ntoplw) * rga / sqrt(tnm(i,ntoplw))
+ co2fac(i,1) = diff * co2mmr * pnm(i,ntoplw) * rga
+ alpha1(i) = (1.0 - exp(-1540.0/tnm(i,ntoplw)))**3.0/sqrt(tnm(i,ntoplw))
+ alpha2(i) = (1.0 - exp(-1360.0/tnm(i,ntoplw)))**3.0/sqrt(tnm(i,ntoplw))
+ uco211(i,ntoplw) = 3.42217e3 * co2fac(i,1) * alpha1(i) * exp(-1849.7/tnm(i,ntoplw))
+ uco212(i,ntoplw) = 6.02454e3 * co2fac(i,1) * alpha1(i) * exp(-2782.1/tnm(i,ntoplw))
+ uco213(i,ntoplw) = 5.53143e3 * co2fac(i,1) * alpha1(i) * exp(-3723.2/tnm(i,ntoplw))
+ uco221(i,ntoplw) = 3.88984e3 * co2fac(i,1) * alpha2(i) * exp(-1997.6/tnm(i,ntoplw))
+ uco222(i,ntoplw) = 3.67108e3 * co2fac(i,1) * alpha2(i) * exp(-3843.8/tnm(i,ntoplw))
+ uco223(i,ntoplw) = 6.50642e3 * co2fac(i,1) * alpha2(i) * exp(-2989.7/tnm(i,ntoplw))
+ bn2o0(i,ntoplw) = diff * 19.399 * pnm(i,ntoplw)**2.0 * n2o(i,ntoplw) * &
+ 1.02346e5 * rga / (sslp*tnm(i,ntoplw))
+ bn2o1(i,ntoplw) = bn2o0(i,ntoplw) * exp(-847.36/tnm(i,ntoplw)) * 2.06646e5
+ bch4(i,ntoplw) = diff * 2.94449 * ch4(i,ntoplw) * pnm(i,ntoplw)**2.0 * rga * &
+ 8.60957e4 / (sslp*tnm(i,ntoplw))
+ uptype(i,ntoplw) = diff * qnm(i,ntoplw) * pnm(i,ntoplw)**2.0 * &
+ exp(1800.0*(1.0/tnm(i,ntoplw) - 1.0/296.0)) * rga / sslp
+ end do
+!
+! Calculate trace gas path lengths through model atmosphere
+!
+ do k = ntoplw,pver
+ do i = 1,ncol
+ rt(i) = 1./tnm(i,k)
+ rsqrt(i) = sqrt(rt(i))
+ pbar(i) = 0.5 * (pnm(i,k+1) + pnm(i,k)) / sslp
+ dpnm(i) = (pnm(i,k+1) - pnm(i,k)) * rga
+ alpha1(i) = diff * rsqrt(i) * (1.0 - exp(-1540.0/tnm(i,k)))**3.0
+ alpha2(i) = diff * rsqrt(i) * (1.0 - exp(-1360.0/tnm(i,k)))**3.0
+ ucfc11(i,k+1) = ucfc11(i,k) + 1.8 * cfc11(i,k) * dpnm(i)
+ ucfc12(i,k+1) = ucfc12(i,k) + 1.8 * cfc12(i,k) * dpnm(i)
+ un2o0(i,k+1) = un2o0(i,k) + diff * 1.02346e5 * n2o(i,k) * rsqrt(i) * dpnm(i)
+ un2o1(i,k+1) = un2o1(i,k) + diff * 2.06646e5 * n2o(i,k) * &
+ rsqrt(i) * exp(-847.36/tnm(i,k)) * dpnm(i)
+ uch4(i,k+1) = uch4(i,k) + diff * 8.60957e4 * ch4(i,k) * rsqrt(i) * dpnm(i)
+ uco211(i,k+1) = uco211(i,k) + 1.15*3.42217e3 * alpha1(i) * &
+ co2mmr * exp(-1849.7/tnm(i,k)) * dpnm(i)
+ uco212(i,k+1) = uco212(i,k) + 1.15*6.02454e3 * alpha1(i) * &
+ co2mmr * exp(-2782.1/tnm(i,k)) * dpnm(i)
+ uco213(i,k+1) = uco213(i,k) + 1.15*5.53143e3 * alpha1(i) * &
+ co2mmr * exp(-3723.2/tnm(i,k)) * dpnm(i)
+ uco221(i,k+1) = uco221(i,k) + 1.15*3.88984e3 * alpha2(i) * &
+ co2mmr * exp(-1997.6/tnm(i,k)) * dpnm(i)
+ uco222(i,k+1) = uco222(i,k) + 1.15*3.67108e3 * alpha2(i) * &
+ co2mmr * exp(-3843.8/tnm(i,k)) * dpnm(i)
+ uco223(i,k+1) = uco223(i,k) + 1.15*6.50642e3 * alpha2(i) * &
+ co2mmr * exp(-2989.7/tnm(i,k)) * dpnm(i)
+ bn2o0(i,k+1) = bn2o0(i,k) + diff * 19.399 * pbar(i) * rt(i) &
+ * 1.02346e5 * n2o(i,k) * dpnm(i)
+ bn2o1(i,k+1) = bn2o1(i,k) + diff * 19.399 * pbar(i) * rt(i) &
+ * 2.06646e5 * exp(-847.36/tnm(i,k)) * n2o(i,k)*dpnm(i)
+ bch4(i,k+1) = bch4(i,k) + diff * 2.94449 * rt(i) * pbar(i) &
+ * 8.60957e4 * ch4(i,k) * dpnm(i)
+ uptype(i,k+1) = uptype(i,k) + diff *qnm(i,k) * &
+ exp(1800.0*(1.0/tnm(i,k) - 1.0/296.0)) * pbar(i) * dpnm(i)
+ end do
+ end do
+!
+ return
+end subroutine trcpth
+
+
+
+subroutine aqsat(t ,p ,es ,qs ,ii , &
+ ilen ,kk ,kstart ,kend )
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Utility procedure to look up and return saturation vapor pressure from
+! precomputed table, calculate and return saturation specific humidity
+! (g/g),for input arrays of temperature and pressure (dimensioned ii,kk)
+! This routine is useful for evaluating only a selected region in the
+! vertical.
+!
+! Method:
+! <Describe the algorithm(s) used in the routine.>
+! <Also include any applicable external references.>
+!
+! Author: J. Hack
+!
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+ integer, intent(in) :: ii ! I dimension of arrays t, p, es, qs
+ integer, intent(in) :: kk ! K dimension of arrays t, p, es, qs
+ integer, intent(in) :: ilen ! Length of vectors in I direction which
+ integer, intent(in) :: kstart ! Starting location in K direction
+ integer, intent(in) :: kend ! Ending location in K direction
+ real(r8), intent(in) :: t(ii,kk) ! Temperature
+ real(r8), intent(in) :: p(ii,kk) ! Pressure
+!
+! Output arguments
+!
+ real(r8), intent(out) :: es(ii,kk) ! Saturation vapor pressure
+ real(r8), intent(out) :: qs(ii,kk) ! Saturation specific humidity
+!
+!---------------------------Local workspace-----------------------------
+!
+ real(r8) omeps ! 1 - 0.622
+ integer i, k ! Indices
+!
+!-----------------------------------------------------------------------
+!
+ omeps = 1.0 - epsqs
+ do k=kstart,kend
+ do i=1,ilen
+ es(i,k) = estblf(t(i,k))
+!
+! Saturation specific humidity
+!
+ qs(i,k) = epsqs*es(i,k)/(p(i,k) - omeps*es(i,k))
+!
+! The following check is to avoid the generation of negative values
+! that can occur in the upper stratosphere and mesosphere
+!
+ qs(i,k) = min(1.0_r8,qs(i,k))
+!
+ if (qs(i,k) < 0.0) then
+ qs(i,k) = 1.0
+ es(i,k) = p(i,k)
+ end if
+ end do
+ end do
+!
+ return
+end subroutine aqsat
+!===============================================================================
+ subroutine cldefr(lchnk ,ncol ,pcols, pver, pverp, &
+ landfrac,t ,rel ,rei ,ps ,pmid , landm, icefrac, snowh)
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Compute cloud water and ice particle size
+!
+! Method:
+! use empirical formulas to construct effective radii
+!
+! Author: J.T. Kiehl, B. A. Boville, P. Rasch
+!
+!-----------------------------------------------------------------------
+
+ implicit none
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+ integer, intent(in) :: lchnk ! chunk identifier
+ integer, intent(in) :: ncol ! number of atmospheric columns
+ integer, intent(in) :: pcols, pver, pverp
+
+ real(r8), intent(in) :: landfrac(pcols) ! Land fraction
+ real(r8), intent(in) :: icefrac(pcols) ! Ice fraction
+ real(r8), intent(in) :: t(pcols,pver) ! Temperature
+ real(r8), intent(in) :: ps(pcols) ! Surface pressure
+ real(r8), intent(in) :: pmid(pcols,pver) ! Midpoint pressures
+ real(r8), intent(in) :: landm(pcols)
+ real(r8), intent(in) :: snowh(pcols) ! Snow depth over land, water equivalent (m)
+!
+! Output arguments
+!
+ real(r8), intent(out) :: rel(pcols,pver) ! Liquid effective drop size (microns)
+ real(r8), intent(out) :: rei(pcols,pver) ! Ice effective drop size (microns)
+!
+
+!++pjr
+! following Kiehl
+ call reltab(ncol, pcols, pver, t, landfrac, landm, icefrac, rel, snowh)
+
+! following Kristjansson and Mitchell
+ call reitab(ncol, pcols, pver, t, rei)
+!--pjr
+!
+!
+ return
+ end subroutine cldefr
+
+
+subroutine background(lchnk, ncol, pint, pcols, pverr, pverrp, mmr)
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Set global mean tropospheric aerosol background (or tuning) field
+!
+! Method:
+! Specify aerosol mixing ratio.
+! Aerosol mass mixing ratio
+! is specified so that the column visible aerosol optical depth is a
+! specified global number (tauback). This means that the actual mixing
+! ratio depends on pressure thickness of the lowest three atmospheric
+! layers near the surface.
+!
+!-----------------------------------------------------------------------
+! use shr_kind_mod, only: r8 => shr_kind_r8
+! use aer_optics, only: kbg,idxVIS
+! use physconst, only: gravit
+!-----------------------------------------------------------------------
+ implicit none
+!-----------------------------------------------------------------------
+!#include <ptrrgrid.h>
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+ integer, intent(in) :: lchnk ! chunk identifier
+ integer, intent(in) :: ncol ! number of atmospheric columns
+ integer, intent(in) :: pcols,pverr,pverrp
+
+ real(r8), intent(in) :: pint(pcols,pverrp) ! Interface pressure (mks)
+!
+! Output arguments
+!
+ real(r8), intent(out) :: mmr(pcols,pverr) ! "background" aerosol mass mixing ratio
+!
+!---------------------------Local variables-----------------------------
+!
+ integer i ! Longitude index
+ integer k ! Level index
+!
+ real(r8) mass2mmr ! Factor to convert mass to mass mixing ratio
+ real(r8) mass ! Mass of "background" aerosol as specified by tauback
+!
+!-----------------------------------------------------------------------
+!
+ do i=1,ncol
+ mass2mmr = gravmks / (pint(i,pverrp)-pint(i,pverrp-mxaerl))
+ do k=1,pverr
+!
+! Compute aerosol mass mixing ratio for specified levels (1.e3 factor is
+! for units conversion of the extinction coefficiant from m2/g to m2/kg)
+!
+ if ( k >= pverrp-mxaerl ) then
+! kaervs is not consistent with the values in aer_optics
+! this ?should? be changed.
+! rhfac is also implemented differently
+ mass = tauback / (1.e3 * kbg(idxVIS))
+ mmr(i,k) = mass2mmr*mass
+ else
+ mmr(i,k) = 0._r8
+ endif
+!
+ enddo
+ enddo
+!
+ return
+end subroutine background
+
+subroutine scale_aerosols(AEROSOLt, pcols, pver, ncol, lchnk, scale)
+!-----------------------------------------------------------------
+! scale each species as determined by scale factors
+!-----------------------------------------------------------------
+ integer, intent(in) :: ncol, lchnk ! number of columns and chunk index
+ integer, intent(in) :: pcols, pver
+ real(r8), intent(in) :: scale(naer_all) ! scale each aerosol by this amount
+ real(r8), intent(inout) :: AEROSOLt(pcols, pver, naer_all) ! aerosols
+ integer m
+
+ do m = 1, naer_all
+ AEROSOLt(:ncol, :, m) = scale(m)*AEROSOLt(:ncol, :, m)
+ end do
+
+ return
+end subroutine scale_aerosols
+
+subroutine get_int_scales(scales)
+ real(r8), intent(out)::scales(naer_all) ! scale each aerosol by this amount
+ integer i ! index through species
+
+!initialize
+ scales = 1.
+
+ scales(idxBG) = 1._r8
+ scales(idxSUL) = sulscl
+ scales(idxSSLT) = ssltscl
+
+ do i = idxCARBONfirst, idxCARBONfirst+numCARBON-1
+ scales(i) = carscl
+ enddo
+
+ do i = idxDUSTfirst, idxDUSTfirst+numDUST-1
+ scales(i) = dustscl
+ enddo
+
+ scales(idxVOLC) = volcscl
+
+ return
+end subroutine get_int_scales
+
+subroutine vert_interpolate (Match_ps, aerosolc, m_hybi, paerlev, naer_c, pint, n, AEROSOL_mmr, pcols, pver, pverp, ncol, c)
+!--------------------------------------------------------------------
+! Input: match surface pressure, cam interface pressure,
+! month index, number of columns, chunk index
+!
+! Output: Aerosol mass mixing ratio (AEROSOL_mmr)
+!
+! Method:
+! interpolate column mass (cumulative) from match onto
+! cam's vertical grid (pressure coordinate)
+! convert back to mass mixing ratio
+!
+!--------------------------------------------------------------------
+
+! use physconst, only: gravit
+
+ integer, intent(in) :: paerlev,naer_c,pcols,pver,pverp
+ real(r8), intent(out) :: AEROSOL_mmr(pcols,pver,naer) ! aerosol mmr from MATCH
+ real(r8), intent(in) :: Match_ps(pcols) ! surface pressure at a particular month
+ real(r8), intent(in) :: pint(pcols,pverp) ! interface pressure from CAM
+ real(r8), intent(in) :: aerosolc(pcols,paerlev,naer_c)
+ real(r8), intent(in) :: m_hybi(paerlev)
+
+ integer, intent(in) :: ncol,c ! chunk index and number of columns
+ integer, intent(in) :: n ! prv or nxt month index
+!
+! Local workspace
+!
+ integer m ! index to aerosol species
+ integer kupper(pcols) ! last upper bound for interpolation
+ integer i, k, kk, kkstart, kount ! loop vars for interpolation
+ integer isv, ksv, msv ! loop indices to save
+
+ logical bad ! indicates a bad point found
+ logical lev_interp_comp ! interpolation completed for a level
+
+ real(r8) AEROSOL(pcols,pverp,naer) ! cumulative mass of aerosol in column beneath upper
+ ! interface of level in column at particular month
+ real(r8) dpl, dpu ! lower and upper intepolation factors
+ real(r8) v_coord ! vertical coordinate
+ real(r8) m_to_mmr ! mass to mass mixing ratio conversion factor
+ real(r8) AER_diff ! temp var for difference between aerosol masses
+
+! call t_startf ('vert_interpolate')
+!
+! Initialize index array
+!
+ do i=1,ncol
+ kupper(i) = 1
+ end do
+!
+! assign total mass to topmost level
+!
+
+ do i=1,ncol
+ do m=1,naer
+ AEROSOL(i,1,m) = AEROSOLc(i,1,m)
+ enddo
+ enddo
+!
+! At every pressure level, interpolate onto that pressure level
+!
+ do k=2,pver
+!
+! Top level we need to start looking is the top level for the previous k
+! for all longitude points
+!
+ kkstart = paerlev
+ do i=1,ncol
+ kkstart = min0(kkstart,kupper(i))
+ end do
+ kount = 0
+!
+! Store level indices for interpolation
+!
+! for the pressure interpolation should be comparing
+! pint(column,lev) with M_hybi(lev)*M_ps_cam_col(month,column,chunk)
+!
+ lev_interp_comp = .false.
+ do kk=kkstart,paerlev-1
+ if(.not.lev_interp_comp) then
+ do i=1,ncol
+ v_coord = pint(i,k)
+ if (M_hybi(kk)*Match_ps(i) .lt. v_coord .and. v_coord .le. M_hybi(kk+1)*Match_ps(i)) then
+ kupper(i) = kk
+ kount = kount + 1
+ end if
+ end do
+!
+! If all indices for this level have been found, do the interpolation and
+! go to the next level
+!
+! Interpolate in pressure.
+!
+ if (kount.eq.ncol) then
+ do i=1,ncol
+ do m=1,naer
+ dpu = pint(i,k) - M_hybi(kupper(i))*Match_ps(i)
+ dpl = M_hybi(kupper(i)+1)*Match_ps(i) - pint(i,k)
+ AEROSOL(i,k,m) = &
+ (AEROSOLc(i,kupper(i) ,m)*dpl + &
+ AEROSOLc(i,kupper(i)+1,m)*dpu)/(dpl + dpu)
+ enddo
+ enddo !i
+ lev_interp_comp = .true.
+ end if
+ end if
+ end do
+!
+! If we've fallen through the kk=1,levsiz-1 loop, we cannot interpolate and
+
+! must extrapolate from the bottom or top pressure level for at least some
+! of the longitude points.
+!
+
+ if(.not.lev_interp_comp) then
+ do i=1,ncol
+ do m=1,naer
+ if (pint(i,k) .lt. M_hybi(1)*Match_ps(i)) then
+ AEROSOL(i,k,m) = AEROSOLc(i,1,m)
+ else if (pint(i,k) .gt. M_hybi(paerlev)*Match_ps(i)) then
+ AEROSOL(i,k,m) = 0.0
+ else
+ dpu = pint(i,k) - M_hybi(kupper(i))*Match_ps(i)
+ dpl = M_hybi(kupper(i)+1)*Match_ps(i) - pint(i,k)
+ AEROSOL(i,k,m) = &
+ (AEROSOLc(i,kupper(i) ,m)*dpl + &
+ AEROSOLc(i,kupper(i)+1,m)*dpu)/(dpl + dpu)
+ end if
+ enddo
+ end do
+
+ if (kount.gt.ncol) then
+ call endrun ('VERT_INTERPOLATE: Bad data: non-monotonicity suspected in dependent variable')
+ end if
+ end if
+ end do
+
+! call t_startf ('vi_checks')
+!
+! aerosol mass beneath lowest interface (pverp) must be 0
+!
+ AEROSOL(1:ncol,pverp,:) = 0.
+!
+! Set mass in layer to zero whenever it is less than
+! 1.e-40 kg/m^2 in the layer
+!
+ do m = 1, naer
+ do k = 1, pver
+ do i = 1, ncol
+ if (AEROSOL(i,k,m) < 1.e-40_r8) AEROSOL(i,k,m) = 0.
+ end do
+ end do
+ end do
+!
+! Set mass in layer to zero whenever it is less than
+! 10^-15 relative to column total mass
+! convert back to mass mixing ratios.
+! exit if mmr is negative
+!
+ do m = 1, naer
+ do k = 1, pver
+ do i = 1, ncol
+ AER_diff = AEROSOL(i,k,m) - AEROSOL(i,k+1,m)
+ if( abs(AER_diff) < 1e-15*AEROSOL(i,1,m)) then
+ AER_diff = 0.
+ end if
+ m_to_mmr = gravmks / (pint(i,k+1)-pint(i,k))
+ AEROSOL_mmr(i,k,m)= AER_diff * m_to_mmr
+ if (AEROSOL_mmr(i,k,m) < 0) then
+ write(6,*)'vert_interpolate: mmr < 0, m, col, lev, mmr',m, i, k, AEROSOL_mmr(i,k,m)
+ write(6,*)'vert_interpolate: aerosol(k),(k+1)',AEROSOL(i,k,m),AEROSOL(i,k+1,m)
+ write(6,*)'vert_interpolate: pint(k+1),(k)',pint(i,k+1),pint(i,k)
+ write(6,*)'n,c',n,c
+ call endrun()
+ end if
+ end do
+ end do
+ end do
+
+! call t_stopf ('vi_checks')
+! call t_stopf ('vert_interpolate')
+
+ return
+end subroutine vert_interpolate
+
+
+!===============================================================================
+ subroutine cldems(lchnk ,ncol ,pcols, pver, pverp, clwp ,fice ,rei ,emis )
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Compute cloud emissivity using cloud liquid water path (g/m**2)
+!
+! Method:
+! <Describe the algorithm(s) used in the routine.>
+! <Also include any applicable external references.>
+!
+! Author: J.T. Kiehl
+!
+!-----------------------------------------------------------------------
+
+ implicit none
+!------------------------------Parameters-------------------------------
+!
+ real(r8) kabsl ! longwave liquid absorption coeff (m**2/g)
+ parameter (kabsl = 0.090361)
+!
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+ integer, intent(in) :: lchnk ! chunk identifier
+ integer, intent(in) :: ncol ! number of atmospheric columns
+ integer, intent(in) :: pcols, pver, pverp
+
+ real(r8), intent(in) :: clwp(pcols,pver) ! cloud liquid water path (g/m**2)
+ real(r8), intent(in) :: rei(pcols,pver) ! ice effective drop size (microns)
+ real(r8), intent(in) :: fice(pcols,pver) ! fractional ice content within cloud
+!
+! Output arguments
+!
+ real(r8), intent(out) :: emis(pcols,pver) ! cloud emissivity (fraction)
+!
+!---------------------------Local workspace-----------------------------
+!
+ integer i,k ! longitude, level indices
+ real(r8) kabs ! longwave absorption coeff (m**2/g)
+ real(r8) kabsi ! ice absorption coefficient
+!
+!-----------------------------------------------------------------------
+!
+ do k=1,pver
+ do i=1,ncol
+ kabsi = 0.005 + 1./rei(i,k)
+ kabs = kabsl*(1.-fice(i,k)) + kabsi*fice(i,k)
+ emis(i,k) = 1. - exp(-1.66*kabs*clwp(i,k))
+ end do
+ end do
+!
+ return
+ end subroutine cldems
+
+!===============================================================================
+ subroutine cldovrlap(lchnk ,ncol ,pcols, pver, pverp, pint ,cld ,nmxrgn ,pmxrgn )
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Partitions each column into regions with clouds in neighboring layers.
+! This information is used to implement maximum overlap in these regions
+! with random overlap between them.
+! On output,
+! nmxrgn contains the number of regions in each column
+! pmxrgn contains the interface pressures for the lower boundaries of
+! each region!
+! Method:
+
+!
+! Author: W. Collins
+!
+!-----------------------------------------------------------------------
+
+ implicit none
+!
+! Input arguments
+!
+ integer, intent(in) :: lchnk ! chunk identifier
+ integer, intent(in) :: ncol ! number of atmospheric columns
+ integer, intent(in) :: pcols, pver, pverp
+
+ real(r8), intent(in) :: pint(pcols,pverp) ! Interface pressure
+ real(r8), intent(in) :: cld(pcols,pver) ! Fractional cloud cover
+!
+! Output arguments
+!
+ real(r8), intent(out) :: pmxrgn(pcols,pverp)! Maximum values of pressure for each
+! maximally overlapped region.
+! 0->pmxrgn(i,1) is range of pressure for
+! 1st region,pmxrgn(i,1)->pmxrgn(i,2) for
+! 2nd region, etc
+ integer nmxrgn(pcols) ! Number of maximally overlapped regions
+!
+!---------------------------Local variables-----------------------------
+!
+ integer i ! Longitude index
+ integer k ! Level index
+ integer n ! Max-overlap region counter
+
+ real(r8) pnm(pcols,pverp) ! Interface pressure
+
+ logical cld_found ! Flag for detection of cloud
+ logical cld_layer(pver) ! Flag for cloud in layer
+!
+!------------------------------------------------------------------------
+!
+
+ do i = 1, ncol
+ cld_found = .false.
+ cld_layer(:) = cld(i,:) > 0.0_r8
+ pmxrgn(i,:) = 0.0
+ pnm(i,:)=pint(i,:)*10.
+ n = 1
+ do k = 1, pver
+ if (cld_layer(k) .and. .not. cld_found) then
+ cld_found = .true.
+ else if ( .not. cld_layer(k) .and. cld_found) then
+ cld_found = .false.
+ if (count(cld_layer(k:pver)) == 0) then
+ exit
+ endif
+ pmxrgn(i,n) = pnm(i,k)
+ n = n + 1
+ endif
+ end do
+ pmxrgn(i,n) = pnm(i,pverp)
+ nmxrgn(i) = n
+ end do
+
+ return
+ end subroutine cldovrlap
+
+!===============================================================================
+ subroutine cldclw(lchnk ,ncol ,pcols, pver, pverp, zi ,clwp ,tpw ,hl )
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Evaluate cloud liquid water path clwp (g/m**2)
+!
+! Method:
+! <Describe the algorithm(s) used in the routine.>
+! <Also include any applicable external references.>
+!
+! Author: J.T. Kiehl
+!
+!-----------------------------------------------------------------------
+
+ implicit none
+
+!
+! Input arguments
+!
+ integer, intent(in) :: lchnk ! chunk identifier
+ integer, intent(in) :: ncol ! number of atmospheric columns
+ integer, intent(in) :: pcols, pver, pverp
+
+ real(r8), intent(in) :: zi(pcols,pverp) ! height at layer interfaces(m)
+ real(r8), intent(in) :: tpw(pcols) ! total precipitable water (mm)
+!
+! Output arguments
+!
+ real(r8) clwp(pcols,pver) ! cloud liquid water path (g/m**2)
+ real(r8) hl(pcols) ! liquid water scale height
+ real(r8) rhl(pcols) ! 1/hl
+
+!
+!---------------------------Local workspace-----------------------------
+!
+ integer i,k ! longitude, level indices
+ real(r8) clwc0 ! reference liquid water concentration (g/m**3)
+ real(r8) emziohl(pcols,pverp) ! exp(-zi/hl)
+!
+!-----------------------------------------------------------------------
+!
+! Set reference liquid water concentration
+!
+ clwc0 = 0.21
+!
+! Diagnose liquid water scale height from precipitable water
+!
+ do i=1,ncol
+ hl(i) = 700.0*log(max(tpw(i)+1.0_r8,1.0_r8))
+ rhl(i) = 1.0/hl(i)
+ end do
+!
+! Evaluate cloud liquid water path (vertical integral of exponential fn)
+!
+ do k=1,pverp
+ do i=1,ncol
+ emziohl(i,k) = exp(-zi(i,k)*rhl(i))
+ end do
+ end do
+ do k=1,pver
+ do i=1,ncol
+ clwp(i,k) = clwc0*hl(i)*(emziohl(i,k+1) - emziohl(i,k))
+ end do
+ end do
+!
+ return
+ end subroutine cldclw
+
+
+!===============================================================================
+ subroutine reltab(ncol, pcols, pver, t, landfrac, landm, icefrac, rel, snowh)
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Compute cloud water size
+!
+! Method:
+! analytic formula following the formulation originally developed by J. T. Kiehl
+!
+! Author: Phil Rasch
+!
+!-----------------------------------------------------------------------
+! use physconst, only: tmelt
+ implicit none
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+ integer, intent(in) :: ncol
+ integer, intent(in) :: pcols, pver
+ real(r8), intent(in) :: landfrac(pcols) ! Land fraction
+ real(r8), intent(in) :: icefrac(pcols) ! Ice fraction
+ real(r8), intent(in) :: snowh(pcols) ! Snow depth over land, water equivalent (m)
+ real(r8), intent(in) :: landm(pcols) ! Land fraction ramping to zero over ocean
+ real(r8), intent(in) :: t(pcols,pver) ! Temperature
+
+!
+! Output arguments
+!
+ real(r8), intent(out) :: rel(pcols,pver) ! Liquid effective drop size (microns)
+!
+!---------------------------Local workspace-----------------------------
+!
+ integer i,k ! Lon, lev indices
+ real(r8) rliqland ! liquid drop size if over land
+ real(r8) rliqocean ! liquid drop size if over ocean
+ real(r8) rliqice ! liquid drop size if over sea ice
+!
+!-----------------------------------------------------------------------
+!
+ rliqocean = 14.0_r8
+ rliqice = 14.0_r8
+ rliqland = 8.0_r8
+ do k=1,pver
+ do i=1,ncol
+! jrm Reworked effective radius algorithm
+ ! Start with temperature-dependent value appropriate for continental air
+ ! Note: findmcnew has a pressure dependence here
+ rel(i,k) = rliqland + (rliqocean-rliqland) * min(1.0_r8,max(0.0_r8,(tmelt-t(i,k))*0.05))
+ ! Modify for snow depth over land
+ rel(i,k) = rel(i,k) + (rliqocean-rel(i,k)) * min(1.0_r8,max(0.0_r8,snowh(i)*10.))
+ ! Ramp between polluted value over land to clean value over ocean.
+ rel(i,k) = rel(i,k) + (rliqocean-rel(i,k)) * min(1.0_r8,max(0.0_r8,1.0-landm(i)))
+ ! Ramp between the resultant value and a sea ice value in the presence of ice.
+ rel(i,k) = rel(i,k) + (rliqice-rel(i,k)) * min(1.0_r8,max(0.0_r8,icefrac(i)))
+! end jrm
+ end do
+ end do
+ end subroutine reltab
+!===============================================================================
+ subroutine reitab(ncol, pcols, pver, t, re)
+ !
+
+ integer, intent(in) :: ncol, pcols, pver
+ real(r8), intent(out) :: re(pcols,pver)
+ real(r8), intent(in) :: t(pcols,pver)
+ real(r8) corr
+ integer i
+ integer k
+ integer index
+ !
+ do k=1,pver
+ do i=1,ncol
+ index = int(t(i,k)-179.)
+ index = min(max(index,1),94)
+ corr = t(i,k) - int(t(i,k))
+ re(i,k) = retab(index)*(1.-corr) &
+ +retab(index+1)*corr
+ ! re(i,k) = amax1(amin1(re(i,k),30.),10.)
+ end do
+ end do
+ !
+ return
+ end subroutine reitab
+
+ function exp_interpol(x, f, y) result(g)
+
+ ! Purpose:
+ ! interpolates f(x) to point y
+ ! assuming f(x) = f(x0) exp a(x - x0)
+ ! where a = ( ln f(x1) - ln f(x0) ) / (x1 - x0)
+ ! x0 <= x <= x1
+ ! assumes x is monotonically increasing
+
+ ! Author: D. Fillmore
+
+! use shr_kind_mod, only: r8 => shr_kind_r8
+
+ implicit none
+
+ real(r8), intent(in), dimension(:) :: x ! grid points
+ real(r8), intent(in), dimension(:) :: f ! grid function values
+ real(r8), intent(in) :: y ! interpolation point
+ real(r8) :: g ! interpolated function value
+
+ integer :: k ! interpolation point index
+ integer :: n ! length of x
+ real(r8) :: a
+
+ n = size(x)
+
+ ! find k such that x(k) < y =< x(k+1)
+ ! set k = 1 if y <= x(1) and k = n-1 if y > x(n)
+
+ if (y <= x(1)) then
+ k = 1
+ else if (y >= x(n)) then
+ k = n - 1
+ else
+ k = 1
+ do while (y > x(k+1) .and. k < n)
+ k = k + 1
+ end do
+ end if
+
+ ! interpolate
+ a = ( log( f(k+1) / f(k) ) ) / ( x(k+1) - x(k) )
+ g = f(k) * exp( a * (y - x(k)) )
+
+ end function exp_interpol
+
+ function lin_interpol(x, f, y) result(g)
+
+ ! Purpose:
+ ! interpolates f(x) to point y
+ ! assuming f(x) = f(x0) + a * (x - x0)
+ ! where a = ( f(x1) - f(x0) ) / (x1 - x0)
+ ! x0 <= x <= x1
+ ! assumes x is monotonically increasing
+
+ ! Author: D. Fillmore
+
+! use shr_kind_mod, only: r8 => shr_kind_r8
+
+ implicit none
+
+ real(r8), intent(in), dimension(:) :: x ! grid points
+ real(r8), intent(in), dimension(:) :: f ! grid function values
+ real(r8), intent(in) :: y ! interpolation point
+ real(r8) :: g ! interpolated function value
+
+ integer :: k ! interpolation point index
+ integer :: n ! length of x
+ real(r8) :: a
+
+ n = size(x)
+
+ ! find k such that x(k) < y =< x(k+1)
+ ! set k = 1 if y <= x(1) and k = n-1 if y > x(n)
+
+ if (y <= x(1)) then
+ k = 1
+ else if (y >= x(n)) then
+ k = n - 1
+ else
+ k = 1
+ do while (y > x(k+1) .and. k < n)
+ k = k + 1
+ end do
+ end if
+
+ ! interpolate
+ a = ( f(k+1) - f(k) ) / ( x(k+1) - x(k) )
+ g = f(k) + a * (y - x(k))
+
+ end function lin_interpol
+
+ function lin_interpol2(x, f, y) result(g)
+
+ ! Purpose:
+ ! interpolates f(x) to point y
+ ! assuming f(x) = f(x0) + a * (x - x0)
+ ! where a = ( f(x1) - f(x0) ) / (x1 - x0)
+ ! x0 <= x <= x1
+ ! assumes x is monotonically increasing
+
+ ! Author: D. Fillmore :: J. Done changed from r8 to r4
+
+ implicit none
+
+ real, intent(in), dimension(:) :: x ! grid points
+ real, intent(in), dimension(:) :: f ! grid function values
+ real, intent(in) :: y ! interpolation point
+ real :: g ! interpolated function value
+
+ integer :: k ! interpolation point index
+ integer :: n ! length of x
+ real :: a
+
+ n = size(x)
+
+ ! find k such that x(k) < y =< x(k+1)
+ ! set k = 1 if y <= x(1) and k = n-1 if y > x(n)
+
+ if (y <= x(1)) then
+ k = 1
+ else if (y >= x(n)) then
+ k = n - 1
+ else
+ k = 1
+ do while (y > x(k+1) .and. k < n)
+ k = k + 1
+ end do
+ end if
+
+ ! interpolate
+ a = ( f(k+1) - f(k) ) / ( x(k+1) - x(k) )
+ g = f(k) + a * (y - x(k))
+
+ end function lin_interpol2
+
+
+subroutine getfactors (cycflag, np1, cdayminus, cdayplus, cday, &
+ fact1, fact2)
+!---------------------------------------------------------------------------
+!
+! Purpose: Determine time interpolation factors (normally for a boundary dataset)
+! for linear interpolation.
+!
+! Method: Assume 365 days per year. Output variable fact1 will be the weight to
+! apply to data at calendar time "cdayminus", and fact2 the weight to apply
+! to data at time "cdayplus". Combining these values will produce a result
+! valid at time "cday". Output arguments fact1 and fact2 will be between
+! 0 and 1, and fact1 + fact2 = 1 to roundoff.
+!
+! Author: Jim Rosinski
+!
+!---------------------------------------------------------------------------
+ implicit none
+!
+! Arguments
+!
+ logical, intent(in) :: cycflag ! flag indicates whether dataset is being cycled yearly
+
+ integer, intent(in) :: np1 ! index points to forward time slice matching cdayplus
+
+ real(r8), intent(in) :: cdayminus ! calendar day of rearward time slice
+ real(r8), intent(in) :: cdayplus ! calendar day of forward time slice
+ real(r8), intent(in) :: cday ! calenar day to be interpolated to
+ real(r8), intent(out) :: fact1 ! time interpolation factor to apply to rearward time slice
+ real(r8), intent(out) :: fact2 ! time interpolation factor to apply to forward time slice
+
+! character(len=*), intent(in) :: str ! string to be added to print in case of error (normally the callers name)
+!
+! Local workspace
+!
+ real(r8) :: deltat ! time difference (days) between cdayminus and cdayplus
+ real(r8), parameter :: daysperyear = 365. ! number of days in a year
+!
+! Initial sanity checks
+!
+! if (np1 == 1 .and. .not. cycflag) then
+! call endrun ('GETFACTORS:'//str//' cycflag false and forward month index = Jan. not allowed')
+! end if
+
+! if (np1 < 1) then
+! call endrun ('GETFACTORS:'//str//' input arg np1 must be > 0')
+! end if
+
+ if (cycflag) then
+ if ((cday < 1.) .or. (cday > (daysperyear+1.))) then
+ write(6,*) 'GETFACTORS:', ' bad cday=',cday
+ call endrun ()
+ end if
+ else
+ if (cday < 1.) then
+ write(6,*) 'GETFACTORS:', ' bad cday=',cday
+ call endrun ()
+ end if
+ end if
+!
+! Determine time interpolation factors. Account for December-January
+! interpolation if dataset is being cycled yearly.
+!
+ if (cycflag .and. np1 == 1) then ! Dec-Jan interpolation
+ deltat = cdayplus + daysperyear - cdayminus
+ if (cday > cdayplus) then ! We are in December
+ fact1 = (cdayplus + daysperyear - cday)/deltat
+ fact2 = (cday - cdayminus)/deltat
+ else ! We are in January
+ fact1 = (cdayplus - cday)/deltat
+ fact2 = (cday + daysperyear - cdayminus)/deltat
+ end if
+ else
+ deltat = cdayplus - cdayminus
+ fact1 = (cdayplus - cday)/deltat
+ fact2 = (cday - cdayminus)/deltat
+ end if
+
+ if (.not. validfactors (fact1, fact2)) then
+ write(6,*) 'GETFACTORS: ', ' bad fact1 and/or fact2=', fact1, fact2
+ call endrun ()
+ end if
+
+ return
+end subroutine getfactors
+
+logical function validfactors (fact1, fact2)
+!---------------------------------------------------------------------------
+!
+! Purpose: check sanity of time interpolation factors to within 32-bit roundoff
+!
+!---------------------------------------------------------------------------
+ implicit none
+
+ real(r8), intent(in) :: fact1, fact2 ! time interpolation factors
+
+ validfactors = .true.
+ if (abs(fact1+fact2-1.) > 1.e-6 .or. &
+ fact1 > 1.000001 .or. fact1 < -1.e-6 .or. &
+ fact2 > 1.000001 .or. fact2 < -1.e-6) then
+
+ validfactors = .false.
+ end if
+
+ return
+end function validfactors
+
+subroutine get_rf_scales(scales)
+
+ real(r8), intent(out)::scales(naer_all) ! scale aerosols by this amount
+
+ integer i ! loop index
+
+ scales(idxBG) = bgscl_rf
+ scales(idxSUL) = sulscl_rf
+ scales(idxSSLT) = ssltscl_rf
+
+ do i = idxCARBONfirst, idxCARBONfirst+numCARBON-1
+ scales(i) = carscl_rf
+ enddo
+
+ do i = idxDUSTfirst, idxDUSTfirst+numDUST-1
+ scales(i) = dustscl_rf
+ enddo
+
+ scales(idxVOLC) = volcscl_rf
+
+end subroutine get_rf_scales
+
+function psi(tpx,iband)
+!
+! History: First version for Hitran 1996 (C/H/E)
+! Current version for Hitran 2000 (C/LT/E)
+! Short function for Hulst-Curtis-Godson temperature factors for
+! computing effective H2O path
+! Line data for H2O: Hitran 2000, plus H2O patches v11.0 for 1341 missing
+! lines between 500 and 2820 cm^-1.
+! See cfa-www.harvard.edu/HITRAN
+! Isotopes of H2O: all
+! Line widths: air-broadened only (self set to 0)
+! Code for line strengths and widths: GENLN3
+! Reference: Edwards, D.P., 1992: GENLN2, A General Line-by-Line Atmospheric
+! Transmittance and Radiance Model, Version 3.0 Description
+! and Users Guide, NCAR/TN-367+STR, 147 pp.
+!
+! Note: functions have been normalized by dividing by their values at
+! a path temperature of 160K
+!
+! spectral intervals:
+! 1 = 0-800 cm^-1 and 1200-2200 cm^-1
+! 2 = 800-1200 cm^-1
+!
+! Formulae: Goody and Yung, Atmospheric Radiation: Theoretical Basis,
+! 2nd edition, Oxford University Press, 1989.
+! Psi: function for pressure along path
+! eq. 6.30, p. 228
+!
+ real(r8),intent(in):: tpx ! path temperature
+ integer, intent(in):: iband ! band to process
+ real(r8) psi ! psi for given band
+ real(r8),parameter :: psi_r0(nbands) = (/ 5.65308452E-01, -7.30087891E+01/)
+ real(r8),parameter :: psi_r1(nbands) = (/ 4.07519005E-03, 1.22199547E+00/)
+ real(r8),parameter :: psi_r2(nbands) = (/-1.04347237E-05, -7.12256227E-03/)
+ real(r8),parameter :: psi_r3(nbands) = (/ 1.23765354E-08, 1.47852825E-05/)
+
+ psi = (((psi_r3(iband) * tpx) + psi_r2(iband)) * tpx + psi_r1(iband)) * tpx + psi_r0(iband)
+end function psi
+
+function phi(tpx,iband)
+!
+! History: First version for Hitran 1996 (C/H/E)
+! Current version for Hitran 2000 (C/LT/E)
+! Short function for Hulst-Curtis-Godson temperature factors for
+! computing effective H2O path
+! Line data for H2O: Hitran 2000, plus H2O patches v11.0 for 1341 missing
+! lines between 500 and 2820 cm^-1.
+! See cfa-www.harvard.edu/HITRAN
+! Isotopes of H2O: all
+! Line widths: air-broadened only (self set to 0)
+! Code for line strengths and widths: GENLN3
+! Reference: Edwards, D.P., 1992: GENLN2, A General Line-by-Line Atmospheric
+! Transmittance and Radiance Model, Version 3.0 Description
+! and Users Guide, NCAR/TN-367+STR, 147 pp.
+!
+! Note: functions have been normalized by dividing by their values at
+! a path temperature of 160K
+!
+! spectral intervals:
+! 1 = 0-800 cm^-1 and 1200-2200 cm^-1
+! 2 = 800-1200 cm^-1
+!
+! Formulae: Goody and Yung, Atmospheric Radiation: Theoretical Basis,
+! 2nd edition, Oxford University Press, 1989.
+! Phi: function for H2O path
+! eq. 6.25, p. 228
+!
+ real(r8),intent(in):: tpx ! path temperature
+ integer, intent(in):: iband ! band to process
+ real(r8) phi ! phi for given band
+ real(r8),parameter :: phi_r0(nbands) = (/ 9.60917711E-01, -2.21031342E+01/)
+ real(r8),parameter :: phi_r1(nbands) = (/ 4.86076751E-04, 4.24062610E-01/)
+ real(r8),parameter :: phi_r2(nbands) = (/-1.84806265E-06, -2.95543415E-03/)
+ real(r8),parameter :: phi_r3(nbands) = (/ 2.11239959E-09, 7.52470896E-06/)
+
+ phi = (((phi_r3(iband) * tpx) + phi_r2(iband)) * tpx + phi_r1(iband)) &
+ * tpx + phi_r0(iband)
+end function phi
+
+function fh2oself( temp )
+!
+! Short function for H2O self-continuum temperature factor in
+! calculation of effective H2O self-continuum path length
+!
+! H2O Continuum: CKD 2.4
+! Code for continuum: GENLN3
+! Reference: Edwards, D.P., 1992: GENLN2, A General Line-by-Line Atmospheric
+! Transmittance and Radiance Model, Version 3.0 Description
+! and Users Guide, NCAR/TN-367+STR, 147 pp.
+!
+! In GENLN, the temperature scaling of the self-continuum is handled
+! by exponential interpolation/extrapolation from observations at
+! 260K and 296K by:
+!
+! TFAC = (T(IPATH) - 296.0)/(260.0 - 296.0)
+! CSFFT = CSFF296*(CSFF260/CSFF296)**TFAC
+!
+! For 800-1200 cm^-1, (CSFF260/CSFF296) ranges from ~2.1 to ~1.9
+! with increasing wavenumber. The ratio <CSFF260>/<CSFF296>,
+! where <> indicates average over wavenumber, is ~2.07
+!
+! fh2oself is (<CSFF260>/<CSFF296>)**TFAC
+!
+ real(r8),intent(in) :: temp ! path temperature
+ real(r8) fh2oself ! mean ratio of self-continuum at temp and 296K
+
+ fh2oself = 2.0727484**((296.0 - temp) / 36.0)
+end function fh2oself
+
+! from wv_saturation.F90
+
+subroutine esinti(epslon ,latvap ,latice ,rh2o ,cpair ,tmelt )
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Initialize es lookup tables
+!
+! Method:
+! <Describe the algorithm(s) used in the routine.>
+! <Also include any applicable external references.>
+!
+! Author: J. Hack
+!
+!-----------------------------------------------------------------------
+! use shr_kind_mod, only: r8 => shr_kind_r8
+! use wv_saturation, only: gestbl
+ implicit none
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+ real(r8), intent(in) :: epslon ! Ratio of h2o to dry air molecular weights
+ real(r8), intent(in) :: latvap ! Latent heat of vaporization
+ real(r8), intent(in) :: latice ! Latent heat of fusion
+ real(r8), intent(in) :: rh2o ! Gas constant for water vapor
+ real(r8), intent(in) :: cpair ! Specific heat of dry air
+ real(r8), intent(in) :: tmelt ! Melting point of water (K)
+!
+!---------------------------Local workspace-----------------------------
+!
+ real(r8) tmn ! Minimum temperature entry in table
+ real(r8) tmx ! Maximum temperature entry in table
+ real(r8) trice ! Trans range from es over h2o to es over ice
+ logical ip ! Ice phase (true or false)
+!
+!-----------------------------------------------------------------------
+!
+! Specify control parameters first
+!
+ tmn = 173.16
+ tmx = 375.16
+ trice = 20.00
+ ip = .true.
+!
+! Call gestbl to build saturation vapor pressure table.
+!
+ call gestbl(tmn ,tmx ,trice ,ip ,epslon , &
+ latvap ,latice ,rh2o ,cpair ,tmelt )
+!
+ return
+end subroutine esinti
+
+subroutine gestbl(tmn ,tmx ,trice ,ip ,epsil , &
+ latvap ,latice ,rh2o ,cpair ,tmeltx )
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Builds saturation vapor pressure table for later lookup procedure.
+!
+! Method:
+! Uses Goff & Gratch (1946) relationships to generate the table
+! according to a set of free parameters defined below. Auxiliary
+! routines are also included for making rapid estimates (well with 1%)
+! of both es and d(es)/dt for the particular table configuration.
+!
+! Author: J. Hack
+!
+!-----------------------------------------------------------------------
+! use pmgrid, only: masterproc
+ implicit none
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+ real(r8), intent(in) :: tmn ! Minimum temperature entry in es lookup table
+ real(r8), intent(in) :: tmx ! Maximum temperature entry in es lookup table
+ real(r8), intent(in) :: epsil ! Ratio of h2o to dry air molecular weights
+ real(r8), intent(in) :: trice ! Transition range from es over range to es over ice
+ real(r8), intent(in) :: latvap ! Latent heat of vaporization
+ real(r8), intent(in) :: latice ! Latent heat of fusion
+ real(r8), intent(in) :: rh2o ! Gas constant for water vapor
+ real(r8), intent(in) :: cpair ! Specific heat of dry air
+ real(r8), intent(in) :: tmeltx ! Melting point of water (K)
+!
+!---------------------------Local variables-----------------------------
+!
+ real(r8) t ! Temperature
+ real(r8) rgasv
+ real(r8) cp
+ real(r8) hlatf
+ real(r8) ttrice
+ real(r8) hlatv
+ integer n ! Increment counter
+ integer lentbl ! Calculated length of lookup table
+ integer itype ! Ice phase: 0 -> no ice phase
+! 1 -> ice phase, no transition
+! -x -> ice phase, x degree transition
+ logical ip ! Ice phase logical flag
+ logical icephs
+!
+!-----------------------------------------------------------------------
+!
+! Set es table parameters
+!
+ tmin = tmn ! Minimum temperature entry in table
+ tmax = tmx ! Maximum temperature entry in table
+ ttrice = trice ! Trans. range from es over h2o to es over ice
+ icephs = ip ! Ice phase (true or false)
+!
+! Set physical constants required for es calculation
+!
+ epsqs = epsil
+ hlatv = latvap
+ hlatf = latice
+ rgasv = rh2o
+ cp = cpair
+ tmelt = tmeltx
+!
+ lentbl = INT(tmax-tmin+2.000001)
+ if (lentbl .gt. plenest) then
+ write(6,9000) tmax, tmin, plenest
+ call endrun ('GESTBL') ! Abnormal termination
+ end if
+!
+! Begin building es table.
+! Check whether ice phase requested.
+! If so, set appropriate transition range for temperature
+!
+ if (icephs) then
+ if (ttrice /= 0.0) then
+ itype = -ttrice
+ else
+ itype = 1
+ end if
+ else
+ itype = 0
+ end if
+!
+ t = tmin - 1.0
+ do n=1,lentbl
+ t = t + 1.0
+ call gffgch(t,estbl(n),itype)
+ end do
+!
+ do n=lentbl+1,plenest
+ estbl(n) = -99999.0
+ end do
+!
+! Table complete -- Set coefficients for polynomial approximation of
+! difference between saturation vapor press over water and saturation
+! pressure over ice for -ttrice < t < 0 (degrees C). NOTE: polynomial
+! is valid in the range -40 < t < 0 (degrees C).
+!
+! --- Degree 5 approximation ---
+!
+ pcf(1) = 5.04469588506e-01
+ pcf(2) = -5.47288442819e+00
+ pcf(3) = -3.67471858735e-01
+ pcf(4) = -8.95963532403e-03
+ pcf(5) = -7.78053686625e-05
+!
+! --- Degree 6 approximation ---
+!
+!-----pcf(1) = 7.63285250063e-02
+!-----pcf(2) = -5.86048427932e+00
+!-----pcf(3) = -4.38660831780e-01
+!-----pcf(4) = -1.37898276415e-02
+!-----pcf(5) = -2.14444472424e-04
+!-----pcf(6) = -1.36639103771e-06
+!
+#if !(defined(non_hydrostatic_core) || defined(hydrostatic_core))
+ if (masterproc) then
+ write(6,*)' *** SATURATION VAPOR PRESSURE TABLE COMPLETED ***'
+ end if
+#endif
+
+ return
+!
+9000 format('GESTBL: FATAL ERROR *********************************',/, &
+ ' TMAX AND TMIN REQUIRE A LARGER DIMENSION ON THE LENGTH', &
+ ' OF THE SATURATION VAPOR PRESSURE TABLE ESTBL(PLENEST)',/, &
+ ' TMAX, TMIN, AND PLENEST => ', 2f7.2, i3)
+!
+end subroutine gestbl
+
+subroutine gffgch(t ,es ,itype )
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Computes saturation vapor pressure over water and/or over ice using
+! Goff & Gratch (1946) relationships.
+! <Say what the routine does>
+!
+! Method:
+! T (temperature), and itype are input parameters, while es (saturation
+! vapor pressure) is an output parameter. The input parameter itype
+! serves two purposes: a value of zero indicates that saturation vapor
+! pressures over water are to be returned (regardless of temperature),
+! while a value of one indicates that saturation vapor pressures over
+! ice should be returned when t is less than freezing degrees. If itype
+! is negative, its absolute value is interpreted to define a temperature
+! transition region below freezing in which the returned
+! saturation vapor pressure is a weighted average of the respective ice
+! and water value. That is, in the temperature range 0 => -itype
+! degrees c, the saturation vapor pressures are assumed to be a weighted
+! average of the vapor pressure over supercooled water and ice (all
+! water at 0 c; all ice at -itype c). Maximum transition range => 40 c
+!
+! Author: J. Hack
+!
+!-----------------------------------------------------------------------
+! use shr_kind_mod, only: r8 => shr_kind_r8
+! use physconst, only: tmelt
+! use abortutils, only: endrun
+
+ implicit none
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+ real(r8), intent(in) :: t ! Temperature
+!
+! Output arguments
+!
+ integer, intent(inout) :: itype ! Flag for ice phase and associated transition
+
+ real(r8), intent(out) :: es ! Saturation vapor pressure
+!
+!---------------------------Local variables-----------------------------
+!
+ real(r8) e1 ! Intermediate scratch variable for es over water
+ real(r8) e2 ! Intermediate scratch variable for es over water
+ real(r8) eswtr ! Saturation vapor pressure over water
+ real(r8) f ! Intermediate scratch variable for es over water
+ real(r8) f1 ! Intermediate scratch variable for es over water
+ real(r8) f2 ! Intermediate scratch variable for es over water
+ real(r8) f3 ! Intermediate scratch variable for es over water
+ real(r8) f4 ! Intermediate scratch variable for es over water
+ real(r8) f5 ! Intermediate scratch variable for es over water
+ real(r8) ps ! Reference pressure (mb)
+ real(r8) t0 ! Reference temperature (freezing point of water)
+ real(r8) term1 ! Intermediate scratch variable for es over ice
+ real(r8) term2 ! Intermediate scratch variable for es over ice
+ real(r8) term3 ! Intermediate scratch variable for es over ice
+ real(r8) tr ! Transition range for es over water to es over ice
+ real(r8) ts ! Reference temperature (boiling point of water)
+ real(r8) weight ! Intermediate scratch variable for es transition
+ integer itypo ! Intermediate scratch variable for holding itype
+!
+!-----------------------------------------------------------------------
+!
+! Check on whether there is to be a transition region for es
+!
+ if (itype < 0) then
+ tr = abs(float(itype))
+ itypo = itype
+ itype = 1
+ else
+ tr = 0.0
+ itypo = itype
+ end if
+ if (tr > 40.0) then
+ write(6,900) tr
+ call endrun ('GFFGCH') ! Abnormal termination
+ end if
+!
+ if(t < (tmelt - tr) .and. itype == 1) go to 10
+!
+! Water
+!
+ ps = 1013.246
+ ts = 373.16
+ e1 = 11.344*(1.0 - t/ts)
+ e2 = -3.49149*(ts/t - 1.0)
+ f1 = -7.90298*(ts/t - 1.0)
+ f2 = 5.02808*log10(ts/t)
+ f3 = -1.3816*(10.0**e1 - 1.0)/10000000.0
+ f4 = 8.1328*(10.0**e2 - 1.0)/1000.0
+ f5 = log10(ps)
+ f = f1 + f2 + f3 + f4 + f5
+ es = (10.0**f)*100.0
+ eswtr = es
+!
+ if(t >= tmelt .or. itype == 0) go to 20
+!
+! Ice
+!
+10 continue
+ t0 = tmelt
+ term1 = 2.01889049/(t0/t)
+ term2 = 3.56654*log(t0/t)
+ term3 = 20.947031*(t0/t)
+ es = 575.185606e10*exp(-(term1 + term2 + term3))
+!
+ if (t < (tmelt - tr)) go to 20
+!
+! Weighted transition between water and ice
+!
+ weight = min((tmelt - t)/tr,1.0_r8)
+ es = weight*es + (1.0 - weight)*eswtr
+!
+20 continue
+ itype = itypo
+ return
+!
+900 format('GFFGCH: FATAL ERROR ******************************',/, &
+ 'TRANSITION RANGE FOR WATER TO ICE SATURATION VAPOR', &
+ ' PRESSURE, TR, EXCEEDS MAXIMUM ALLOWABLE VALUE OF', &
+ ' 40.0 DEGREES C',/, ' TR = ',f7.2)
+!
+end subroutine gffgch
+
+ real(r8) function estblf( td )
+!
+! Saturation vapor pressure table lookup
+!
+ real(r8), intent(in) :: td ! Temperature for saturation lookup
+!
+ real(r8) :: e ! intermediate variable for es look-up
+ real(r8) :: ai
+ integer :: i
+!
+ e = max(min(td,tmax),tmin) ! partial pressure
+ i = int(e-tmin)+1
+ ai = aint(e-tmin)
+ estblf = (tmin+ai-e+1.)* &
+ estbl(i)-(tmin+ai-e)* &
+ estbl(i+1)
+ end function estblf
+
+
+function findvalue(ix,n,ain,indxa)
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Subroutine for finding ix-th smallest value in the array
+! The elements are rearranged so that the ix-th smallest
+! element is in the ix place and all smaller elements are
+! moved to the elements up to ix (with random order).
+!
+! Algorithm: Based on the quicksort algorithm.
+!
+! Author: T. Craig
+!
+!-----------------------------------------------------------------------
+! use shr_kind_mod, only: r8 => shr_kind_r8
+ implicit none
+!
+! arguments
+!
+ integer, intent(in) :: ix ! element to search for
+ integer, intent(in) :: n ! total number of elements
+ integer, intent(inout):: indxa(n) ! array of integers
+ real(r8), intent(in) :: ain(n) ! array to search
+!
+ integer findvalue ! return value
+!
+! local variables
+!
+ integer i,j
+ integer il,im,ir
+
+ integer ia
+ integer itmp
+!
+!---------------------------Routine-----------------------------
+!
+ il=1
+ ir=n
+ do
+ if (ir-il <= 1) then
+ if (ir-il == 1) then
+ if (ain(indxa(ir)) < ain(indxa(il))) then
+ itmp=indxa(il)
+ indxa(il)=indxa(ir)
+ indxa(ir)=itmp
+ endif
+ endif
+ findvalue=indxa(ix)
+ return
+ else
+ im=(il+ir)/2
+ itmp=indxa(im)
+ indxa(im)=indxa(il+1)
+ indxa(il+1)=itmp
+ if (ain(indxa(il+1)) > ain(indxa(ir))) then
+ itmp=indxa(il+1)
+ indxa(il+1)=indxa(ir)
+ indxa(ir)=itmp
+ endif
+ if (ain(indxa(il)) > ain(indxa(ir))) then
+ itmp=indxa(il)
+ indxa(il)=indxa(ir)
+ indxa(ir)=itmp
+ endif
+ if (ain(indxa(il+1)) > ain(indxa(il))) then
+ itmp=indxa(il+1)
+ indxa(il+1)=indxa(il)
+ indxa(il)=itmp
+ endif
+ i=il+1
+ j=ir
+ ia=indxa(il)
+ do
+ do
+ i=i+1
+ if (ain(indxa(i)) >= ain(ia)) exit
+ end do
+ do
+ j=j-1
+ if (ain(indxa(j)) <= ain(ia)) exit
+ end do
+ if (j < i) exit
+ itmp=indxa(i)
+ indxa(i)=indxa(j)
+ indxa(j)=itmp
+ end do
+ indxa(il)=indxa(j)
+ indxa(j)=ia
+ if (j >= ix)ir=j-1
+ if (j <= ix)il=i
+ endif
+ end do
+end function findvalue
+
+
+!LDF (05-21-2011): This section of the module is moved to module_physics_ra_cam_init.F in
+!./../core_physics to accomodate differences in the mpi calls between WRF and MPAS.I thought
+!that it would be cleaner to do this instead of adding a lot of #ifdef statements throughout
+!the initialization of the longwave radiation code. Initialization is handled the same way
+!for the shortwave radiation code.
+
+#if !(defined(non_hydrostatic_core) || defined(hydrostatic_core))
+
+subroutine radini(gravx ,cpairx ,epsilox ,stebolx, pstdx )
+!-----------------------------------------------------------------------
+!
+! Purpose:
+! Initialize various constants for radiation scheme; note that
+! the radiation scheme uses cgs units.
+!
+! Method:
+! <Describe the algorithm(s) used in the routine.>
+! <Also include any applicable external references.>
+!
+! Author: W. Collins (H2O parameterization) and J. Kiehl
+!
+!-----------------------------------------------------------------------
+! use shr_kind_mod, only: r8 => shr_kind_r8
+! use ppgrid, only: pver, pverp
+! use comozp, only: cplos, cplol
+! use pmgrid, only: masterproc, plev, plevp
+! use radae, only: radaeini
+! use physconst, only: mwdry, mwco2
+#if ( defined SPMD )
+! use mpishorthand
+#endif
+ implicit none
+
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+ real, intent(in) :: gravx ! Acceleration of gravity (MKS)
+ real, intent(in) :: cpairx ! Specific heat of dry air (MKS)
+ real, intent(in) :: epsilox ! Ratio of mol. wght of H2O to dry air
+ real, intent(in) :: stebolx ! Stefan-Boltzmann's constant (MKS)
+ real(r8), intent(in) :: pstdx ! Standard pressure (Pascals)
+!
+!---------------------------Local variables-----------------------------
+!
+ integer k ! Loop variable
+
+ real(r8) v0 ! Volume of a gas at stp (m**3/kmol)
+ real(r8) p0 ! Standard pressure (pascals)
+ real(r8) amd ! Effective molecular weight of dry air (kg/kmol)
+ real(r8) goz ! Acceleration of gravity (m/s**2)
+!
+!-----------------------------------------------------------------------
+!
+! Set general radiation consts; convert to cgs units where appropriate:
+!
+ gravit = 100.*gravx
+ rga = 1./gravit
+ gravmks = gravx
+ cpair = 1.e4*cpairx
+ epsilo = epsilox
+ sslp = 1.013250e6
+ stebol = 1.e3*stebolx
+ rgsslp = 0.5/(gravit*sslp)
+ dpfo3 = 2.5e-3
+ dpfco2 = 5.0e-3
+ dayspy = 365.
+ pie = 4.*atan(1.)
+!
+! Initialize ozone data.
+!
+ v0 = 22.4136 ! Volume of a gas at stp (m**3/kmol)
+ p0 = 0.1*sslp ! Standard pressure (pascals)
+ amd = 28.9644 ! Molecular weight of dry air (kg/kmol)
+ goz = gravx ! Acceleration of gravity (m/s**2)
+!
+! Constants for ozone path integrals (multiplication by 100 for unit
+! conversion to cgs from mks):
+!
+ cplos = v0/(amd*goz) *100.0
+ cplol = v0/(amd*goz*p0)*0.5*100.0
+!
+! Derived constants
+! If the top model level is above ~90 km (0.1 Pa), set the top level to compute
+! longwave cooling to about 80 km (1 Pa)
+! WRF: assume top level > 0.1 mb
+! if (hypm(1) .lt. 0.1) then
+! do k = 1, pver
+! if (hypm(k) .lt. 1.) ntoplw = k
+! end do
+! else
+ ntoplw = 1
+! end if
+! if (masterproc) then
+! write (6,*) 'RADINI: ntoplw =',ntoplw, ' pressure:',hypm(ntoplw)
+! endif
+
+ call radaeini( pstdx, mwdry, mwco2 )
+ return
+end subroutine radini
+
+subroutine oznini(ozmixm,pin,levsiz,num_months,XLAT, &
+ ids, ide, jds, jde, kds, kde, &
+ ims, ime, jms, jme, kms, kme, &
+ its, ite, jts, jte, kts, kte)
+!
+! This subroutine assumes uniform distribution of ozone concentration.
+! It should be replaced by monthly climatology that varies latitudinally and vertically
+!
+
+ IMPLICIT NONE
+
+ INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
+ ims,ime, jms,jme, kms,kme, &
+ its,ite, jts,jte, kts,kte
+
+ INTEGER, INTENT(IN ) :: levsiz, num_months
+
+ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: XLAT
+
+ REAL, DIMENSION( ims:ime, levsiz, jms:jme, num_months ), &
+ INTENT(OUT ) :: OZMIXM
+
+ REAL, DIMENSION(levsiz), INTENT(OUT ) :: PIN
+
+! Local
+ INTEGER, PARAMETER :: latsiz = 64
+ INTEGER, PARAMETER :: lonsiz = 1
+ INTEGER :: i, j, k, itf, jtf, ktf, m, pin_unit, lat_unit, oz_unit
+ REAL :: interp_pt
+ CHARACTER*256 :: message
+
+ REAL, DIMENSION( lonsiz, levsiz, latsiz, num_months ) :: &
+ OZMIXIN
+
+ REAL, DIMENSION(latsiz) :: lat_ozone
+
+ jtf=min0(jte,jde-1)
+ ktf=min0(kte,kde-1)
+ itf=min0(ite,ide-1)
+
+
+!-- read in ozone pressure data
+
+ WRITE(message,*)'num_months = ',num_months
+ CALL wrf_debug(50,message)
+
+ pin_unit = 27
+ OPEN(pin_unit, FILE='ozone_plev.formatted',FORM='FORMATTED',STATUS='OLD')
+ do k = 1,levsiz
+ READ (pin_unit,*)pin(k)
+ end do
+ close(27)
+
+ do k=1,levsiz
+ pin(k) = pin(k)*100.
+ end do
+
+!-- read in ozone lat data
+
+ lat_unit = 28
+ OPEN(lat_unit, FILE='ozone_lat.formatted',FORM='FORMATTED',STATUS='OLD')
+ do j = 1,latsiz
+ READ (lat_unit,*)lat_ozone(j)
+ end do
+ close(28)
+
+
+!-- read in ozone data
+
+ oz_unit = 29
+ OPEN(oz_unit, FILE='ozone.formatted',FORM='FORMATTED',STATUS='OLD')
+
+ do m=2,num_months
+ do j=1,latsiz ! latsiz=64
+ do k=1,levsiz ! levsiz=59
+ do i=1,lonsiz ! lonsiz=1
+ READ (oz_unit,*)ozmixin(i,k,j,m)
+ enddo
+ enddo
+ enddo
+ enddo
+ close(29)
+
+
+!-- latitudinally interpolate ozone data (and extend longitudinally)
+!-- using function lin_interpol2(x, f, y) result(g)
+! Purpose:
+! interpolates f(x) to point y
+! assuming f(x) = f(x0) + a * (x - x0)
+! where a = ( f(x1) - f(x0) ) / (x1 - x0)
+! x0 <= x <= x1
+! assumes x is monotonically increasing
+! real, intent(in), dimension(:) :: x ! grid points
+! real, intent(in), dimension(:) :: f ! grid function values
+! real, intent(in) :: y ! interpolation point
+! real :: g ! interpolated function value
+!---------------------------------------------------------------------------
+
+ do m=2,num_months
+ do j=jts,jtf
+ do k=1,levsiz
+ do i=its,itf
+ interp_pt=XLAT(i,j)
+ ozmixm(i,k,j,m)=lin_interpol2(lat_ozone(:),ozmixin(1,k,:,m),interp_pt)
+ enddo
+ enddo
+ enddo
+ enddo
+
+! Old code for fixed ozone
+
+! pin(1)=70.
+! DO k=2,levsiz
+! pin(k)=pin(k-1)+16.
+! ENDDO
+
+! DO k=1,levsiz
+! pin(k) = pin(k)*100.
+! end do
+
+! DO m=1,num_months
+! DO j=jts,jtf
+! DO i=its,itf
+! DO k=1,2
+! ozmixm(i,k,j,m)=1.e-6
+! ENDDO
+! DO k=3,levsiz
+! ozmixm(i,k,j,m)=1.e-7
+! ENDDO
+! ENDDO
+! ENDDO
+! ENDDO
+
+END SUBROUTINE oznini
+
+
+subroutine aerosol_init(m_psp,m_psn,m_hybi,aerosolcp,aerosolcn,paerlev,naer_c,shalf,pptop, &
+ ids, ide, jds, jde, kds, kde, &
+ ims, ime, jms, jme, kms, kme, &
+ its, ite, jts, jte, kts, kte)
+!
+! This subroutine assumes a uniform aerosol distribution in both time and space.
+! It should be modified if aerosol data are available from WRF-CHEM or other sources
+!
+ IMPLICIT NONE
+
+ INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
+ ims,ime, jms,jme, kms,kme, &
+ its,ite, jts,jte, kts,kte
+
+ INTEGER, INTENT(IN ) :: paerlev,naer_c
+
+ REAL, intent(in) :: pptop
+ REAL, DIMENSION( kms:kme ), intent(in) :: shalf
+
+ REAL, DIMENSION( ims:ime, paerlev, jms:jme, naer_c ), &
+ INTENT(INOUT ) :: aerosolcn , aerosolcp
+
+ REAL, DIMENSION(paerlev), INTENT(OUT ) :: m_hybi
+ REAL, DIMENSION( ims:ime, jms:jme), INTENT(OUT ) :: m_psp,m_psn
+
+ REAL :: psurf
+ real, dimension(29) :: hybi
+ integer k ! index through vertical levels
+
+ INTEGER :: i, j, itf, jtf, ktf,m
+
+ data hybi/0, 0.0065700002014637, 0.0138600002974272, 0.023089999333024, &
+ 0.0346900001168251, 0.0491999983787537, 0.0672300010919571, &
+ 0.0894500017166138, 0.116539999842644, 0.149159997701645, &
+ 0.187830001115799, 0.232859998941422, 0.284209996461868, &
+ 0.341369986534119, 0.403340011835098, 0.468600004911423, &
+ 0.535290002822876, 0.601350009441376, 0.66482001543045, &
+ 0.724009990692139, 0.777729988098145, 0.825269997119904, &
+ 0.866419970989227, 0.901350021362305, 0.930540025234222, &
+ 0.954590022563934, 0.974179983139038, 0.990000009536743, 1/
+
+ jtf=min0(jte,jde-1)
+ ktf=min0(kte,kde-1)
+ itf=min0(ite,ide-1)
+
+ do k=1,paerlev
+ m_hybi(k)=hybi(k)
+ enddo
+
+!
+! mxaerl = max number of levels (from bottom) for background aerosol
+! Limit background aerosol height to regions below 900 mb
+!
+
+ psurf = 1.e05
+ mxaerl = 0
+! do k=pver,1,-1
+ do k=kms,kme-1
+! if (hypm(k) >= 9.e4) mxaerl = mxaerl + 1
+ if (shalf(k)*psurf+pptop >= 9.e4) mxaerl = mxaerl + 1
+ end do
+ mxaerl = max(mxaerl,1)
+! if (masterproc) then
+ write(6,*)'AEROSOLS: Background aerosol will be limited to ', &
+ 'bottom ',mxaerl,' model interfaces.'
+! 'bottom ',mxaerl,' model interfaces. Top interface is ', &
+! hypi(pverp-mxaerl),' pascals'
+! end if
+
+ DO j=jts,jtf
+ DO i=its,itf
+ m_psp(i,j)=psurf
+ m_psn(i,j)=psurf
+ ENDDO
+ ENDDO
+
+ DO j=jts,jtf
+ DO i=its,itf
+ DO k=1,paerlev
+! aerosolc arrays are upward cumulative (kg/m2) at each level
+! Here we assume uniform vertical distribution (aerosolc linear with hybi)
+ aerosolcp(i,k,j,idxSUL)=1.e-7*(1.-hybi(k))
+ aerosolcn(i,k,j,idxSUL)=1.e-7*(1.-hybi(k))
+ aerosolcp(i,k,j,idxSSLT)=1.e-22*(1.-hybi(k))
+ aerosolcn(i,k,j,idxSSLT)=1.e-22*(1.-hybi(k))
+ aerosolcp(i,k,j,idxDUSTfirst)=1.e-7*(1.-hybi(k))
+ aerosolcn(i,k,j,idxDUSTfirst)=1.e-7*(1.-hybi(k))
+ aerosolcp(i,k,j,idxDUSTfirst+1)=1.e-7*(1.-hybi(k))
+ aerosolcn(i,k,j,idxDUSTfirst+1)=1.e-7*(1.-hybi(k))
+ aerosolcp(i,k,j,idxDUSTfirst+2)=1.e-7*(1.-hybi(k))
+ aerosolcn(i,k,j,idxDUSTfirst+2)=1.e-7*(1.-hybi(k))
+ aerosolcp(i,k,j,idxDUSTfirst+3)=1.e-7*(1.-hybi(k))
+ aerosolcn(i,k,j,idxDUSTfirst+3)=1.e-7*(1.-hybi(k))
+ aerosolcp(i,k,j,idxOCPHO)=1.e-7*(1.-hybi(k))
+ aerosolcn(i,k,j,idxOCPHO)=1.e-7*(1.-hybi(k))
+ aerosolcp(i,k,j,idxBCPHO)=1.e-9*(1.-hybi(k))
+ aerosolcn(i,k,j,idxBCPHO)=1.e-9*(1.-hybi(k))
+ aerosolcp(i,k,j,idxOCPHI)=1.e-7*(1.-hybi(k))
+ aerosolcn(i,k,j,idxOCPHI)=1.e-7*(1.-hybi(k))
+ aerosolcp(i,k,j,idxBCPHI)=1.e-8*(1.-hybi(k))
+ aerosolcn(i,k,j,idxBCPHI)=1.e-8*(1.-hybi(k))
+ ENDDO
+ ENDDO
+ ENDDO
+
+ call aer_optics_initialize
+
+
+END subroutine aerosol_init
+
+ subroutine aer_optics_initialize
+
+USE module_wrf_error
+
+! use shr_kind_mod, only: r8 => shr_kind_r8
+! use pmgrid ! masterproc is here
+! use ioFileMod, only: getfil
+
+!#if ( defined SPMD )
+! use mpishorthand
+!#endif
+ implicit none
+
+! include 'netcdf.inc'
+
+
+ integer :: nrh_opac ! number of relative humidity values for OPAC data
+ integer :: nbnd ! number of spectral bands, should be identical to nspint
+ real(r8), parameter :: wgt_sscm = 6.0 / 7.0
+ integer :: krh_opac ! rh index for OPAC rh grid
+ integer :: krh ! another rh index
+ integer :: ksz ! dust size bin index
+ integer :: kbnd ! band index
+
+ real(r8) :: rh ! local relative humidity variable
+
+ integer, parameter :: irh=8
+ real(r8) :: rh_opac(irh) ! OPAC relative humidity grid
+ real(r8) :: ksul_opac(irh,nspint) ! sulfate extinction
+ real(r8) :: wsul_opac(irh,nspint) ! single scattering albedo
+ real(r8) :: gsul_opac(irh,nspint) ! asymmetry parameter
+ real(r8) :: ksslt_opac(irh,nspint) ! sea-salt
+ real(r8) :: wsslt_opac(irh,nspint)
+ real(r8) :: gsslt_opac(irh,nspint)
+ real(r8) :: kssam_opac(irh,nspint) ! sea-salt accumulation mode
+ real(r8) :: wssam_opac(irh,nspint)
+ real(r8) :: gssam_opac(irh,nspint)
+ real(r8) :: ksscm_opac(irh,nspint) ! sea-salt coarse mode
+ real(r8) :: wsscm_opac(irh,nspint)
+ real(r8) :: gsscm_opac(irh,nspint)
+ real(r8) :: kcphil_opac(irh,nspint) ! hydrophilic organic carbon
+ real(r8) :: wcphil_opac(irh,nspint)
+ real(r8) :: gcphil_opac(irh,nspint)
+ real(r8) :: dummy(nspint)
+
+ LOGICAL :: opened
+ LOGICAL , EXTERNAL :: wrf_dm_on_monitor
+
+ CHARACTER*80 errmess
+ INTEGER cam_aer_unit
+ integer :: i
+
+! read aerosol optics data
+
+ IF ( wrf_dm_on_monitor() ) THEN
+ DO i = 10,99
+ INQUIRE ( i , OPENED = opened )
+ IF ( .NOT. opened ) THEN
+ cam_aer_unit = i
+ GOTO 2010
+ ENDIF
+ ENDDO
+ cam_aer_unit = -1
+ 2010 CONTINUE
+ ENDIF
+ CALL wrf_dm_bcast_bytes ( cam_aer_unit , IWORDSIZE )
+ IF ( cam_aer_unit < 0 ) THEN
+ CALL wrf_error_fatal ( 'module_ra_cam: aer_optics_initialize: Can not find unused fortran unit to read in lookup table.' )
+ ENDIF
+
+ IF ( wrf_dm_on_monitor() ) THEN
+ OPEN(cam_aer_unit,FILE='CAM_AEROPT_DATA', &
+ FORM='UNFORMATTED',STATUS='OLD',ERR=9010)
+ call wrf_debug(50,'reading CAM_AEROPT_DATA')
+ ENDIF
+
+#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * r8 )
+
+ IF ( wrf_dm_on_monitor() ) then
+ READ (cam_aer_unit,ERR=9010) dummy
+ READ (cam_aer_unit,ERR=9010) rh_opac
+ READ (cam_aer_unit,ERR=9010) ksul_opac
+ READ (cam_aer_unit,ERR=9010) wsul_opac
+ READ (cam_aer_unit,ERR=9010) gsul_opac
+ READ (cam_aer_unit,ERR=9010) kssam_opac
+ READ (cam_aer_unit,ERR=9010) wssam_opac
+ READ (cam_aer_unit,ERR=9010) gssam_opac
+ READ (cam_aer_unit,ERR=9010) ksscm_opac
+ READ (cam_aer_unit,ERR=9010) wsscm_opac
+ READ (cam_aer_unit,ERR=9010) gsscm_opac
+ READ (cam_aer_unit,ERR=9010) kcphil_opac
+ READ (cam_aer_unit,ERR=9010) wcphil_opac
+ READ (cam_aer_unit,ERR=9010) gcphil_opac
+ READ (cam_aer_unit,ERR=9010) kcb
+ READ (cam_aer_unit,ERR=9010) wcb
+ READ (cam_aer_unit,ERR=9010) gcb
+ READ (cam_aer_unit,ERR=9010) kdst
+ READ (cam_aer_unit,ERR=9010) wdst
+ READ (cam_aer_unit,ERR=9010) gdst
+ READ (cam_aer_unit,ERR=9010) kbg
+ READ (cam_aer_unit,ERR=9010) wbg
+ READ (cam_aer_unit,ERR=9010) gbg
+ READ (cam_aer_unit,ERR=9010) kvolc
+ READ (cam_aer_unit,ERR=9010) wvolc
+ READ (cam_aer_unit,ERR=9010) gvolc
+ endif
+
+ DM_BCAST_MACRO(rh_opac)
+ DM_BCAST_MACRO(ksul_opac)
+ DM_BCAST_MACRO(wsul_opac)
+ DM_BCAST_MACRO(gsul_opac)
+ DM_BCAST_MACRO(kssam_opac)
+ DM_BCAST_MACRO(wssam_opac)
+ DM_BCAST_MACRO(gssam_opac)
+ DM_BCAST_MACRO(ksscm_opac)
+ DM_BCAST_MACRO(wsscm_opac)
+ DM_BCAST_MACRO(gsscm_opac)
+ DM_BCAST_MACRO(kcphil_opac)
+ DM_BCAST_MACRO(wcphil_opac)
+ DM_BCAST_MACRO(gcphil_opac)
+ DM_BCAST_MACRO(kcb)
+ DM_BCAST_MACRO(wcb)
+ DM_BCAST_MACRO(gcb)
+ DM_BCAST_MACRO(kvolc)
+ DM_BCAST_MACRO(wvolc)
+ DM_BCAST_MACRO(kdst)
+ DM_BCAST_MACRO(wdst)
+ DM_BCAST_MACRO(gdst)
+ DM_BCAST_MACRO(kbg)
+ DM_BCAST_MACRO(wbg)
+ DM_BCAST_MACRO(gbg)
+
+ IF ( wrf_dm_on_monitor() ) CLOSE (cam_aer_unit)
+
+ ! map OPAC aerosol species onto CAM aerosol species
+ ! CAM name OPAC name
+ ! sul or SO4 = suso sulfate soluble
+ ! sslt or SSLT = 1/7 ssam + 6/7 sscm sea-salt accumulation/coagulation mode
+ ! cphil or CPHI = waso water soluble (carbon)
+ ! cphob or CPHO = waso @ rh = 0
+ ! cb or BCPHI/BCPHO = soot
+
+ ksslt_opac(:,:) = (1.0 - wgt_sscm) * kssam_opac(:,:) + wgt_sscm * ksscm_opac(:,:)
+
+ wsslt_opac(:,:) = ( (1.0 - wgt_sscm) * kssam_opac(:,:) * wssam_opac(:,:) &
+ + wgt_sscm * ksscm_opac(:,:) * wsscm_opac(:,:) ) &
+ / ksslt_opac(:,:)
+
+ gsslt_opac(:,:) = ( (1.0 - wgt_sscm) * kssam_opac(:,:) * wssam_opac(:,:) * gssam_opac(:,:) &
+ + wgt_sscm * ksscm_opac(:,:) * wsscm_opac(:,:) * gsscm_opac(:,:) ) &
+ / ( ksslt_opac(:,:) * wsslt_opac(:,:) )
+
+ do i=1,nspint
+ kcphob(i) = kcphil_opac(1,i)
+ wcphob(i) = wcphil_opac(1,i)
+ gcphob(i) = gcphil_opac(1,i)
+ end do
+
+ ! interpolate optical properties of hygrospopic aerosol species
+ ! onto a uniform relative humidity grid
+
+ nbnd = nspint
+
+ do krh = 1, nrh
+ rh = 1.0_r8 / nrh * (krh - 1)
+ do kbnd = 1, nbnd
+ ksul(krh, kbnd) = exp_interpol( rh_opac, &
+ ksul_opac(:, kbnd) / ksul_opac(1, kbnd), rh ) * ksul_opac(1, kbnd)
+ wsul(krh, kbnd) = lin_interpol( rh_opac, &
+ wsul_opac(:, kbnd) / wsul_opac(1, kbnd), rh ) * wsul_opac(1, kbnd)
+ gsul(krh, kbnd) = lin_interpol( rh_opac, &
+ gsul_opac(:, kbnd) / gsul_opac(1, kbnd), rh ) * gsul_opac(1, kbnd)
+ ksslt(krh, kbnd) = exp_interpol( rh_opac, &
+ ksslt_opac(:, kbnd) / ksslt_opac(1, kbnd), rh ) * ksslt_opac(1, kbnd)
+ wsslt(krh, kbnd) = lin_interpol( rh_opac, &
+ wsslt_opac(:, kbnd) / wsslt_opac(1, kbnd), rh ) * wsslt_opac(1, kbnd)
+ gsslt(krh, kbnd) = lin_interpol( rh_opac, &
+ gsslt_opac(:, kbnd) / gsslt_opac(1, kbnd), rh ) * gsslt_opac(1, kbnd)
+ kcphil(krh, kbnd) = exp_interpol( rh_opac, &
+ kcphil_opac(:, kbnd) / kcphil_opac(1, kbnd), rh ) * kcphil_opac(1, kbnd)
+ wcphil(krh, kbnd) = lin_interpol( rh_opac, &
+ wcphil_opac(:, kbnd) / wcphil_opac(1, kbnd), rh ) * wcphil_opac(1, kbnd)
+ gcphil(krh, kbnd) = lin_interpol( rh_opac, &
+ gcphil_opac(:, kbnd) / gcphil_opac(1, kbnd), rh ) * gcphil_opac(1, kbnd)
+ end do
+ end do
+
+ RETURN
+9010 CONTINUE
+ WRITE( errmess , '(A35,I4)' ) 'module_ra_cam: error reading unit ',cam_aer_unit
+ CALL wrf_error_fatal(errmess)
+
+END subroutine aer_optics_initialize
+
+
+subroutine radaeini( pstdx, mwdryx, mwco2x )
+
+USE module_wrf_error
+
+!
+! Initialize radae module data
+!
+!
+! Input variables
+!
+ real(r8), intent(in) :: pstdx ! Standard pressure (dynes/cm^2)
+ real(r8), intent(in) :: mwdryx ! Molecular weight of dry air
+ real(r8), intent(in) :: mwco2x ! Molecular weight of carbon dioxide
+!
+! Variables for loading absorptivity/emissivity
+!
+ integer ncid_ae ! NetCDF file id for abs/ems file
+
+ integer pdimid ! pressure dimension id
+ integer psize ! pressure dimension size
+
+ integer tpdimid ! path temperature dimension id
+ integer tpsize ! path temperature size
+
+ integer tedimid ! emission temperature dimension id
+ integer tesize ! emission temperature size
+
+ integer udimid ! u (H2O path) dimension id
+ integer usize ! u (H2O path) dimension size
+
+ integer rhdimid ! relative humidity dimension id
+ integer rhsize ! relative humidity dimension size
+
+ integer ah2onwid ! var. id for non-wndw abs.
+ integer eh2onwid ! var. id for non-wndw ems.
+ integer ah2owid ! var. id for wndw abs. (adjacent layers)
+ integer cn_ah2owid ! var. id for continuum trans. for wndw abs.
+ integer cn_eh2owid ! var. id for continuum trans. for wndw ems.
+ integer ln_ah2owid ! var. id for line trans. for wndw abs.
+ integer ln_eh2owid ! var. id for line trans. for wndw ems.
+
+! character*(NF_MAX_NAME) tmpname! dummy variable for var/dim names
+ character(len=256) locfn ! local filename
+ integer tmptype ! dummy variable for variable type
+ integer ndims ! number of dimensions
+! integer dims(NF_MAX_VAR_DIMS) ! vector of dimension ids
+ integer natt ! number of attributes
+!
+! Variables for setting up H2O table
+!
+ integer t ! path temperature
+ integer tmin ! mininum path temperature
+ integer tmax ! maximum path temperature
+ integer itype ! type of sat. pressure (=0 -> H2O only)
+ integer i
+ real(r8) tdbl
+
+ LOGICAL :: opened
+ LOGICAL , EXTERNAL :: wrf_dm_on_monitor
+
+ CHARACTER*80 errmess
+ INTEGER cam_abs_unit
+
+!
+! Constants to set
+!
+ p0 = pstdx
+ amd = mwdryx
+ amco2 = mwco2x
+!
+! Coefficients for h2o emissivity and absorptivity for overlap of H2O
+! and trace gases.
+!
+ c16 = coefj(3,1)/coefj(2,1)
+ c17 = coefk(3,1)/coefk(2,1)
+ c26 = coefj(3,2)/coefj(2,2)
+ c27 = coefk(3,2)/coefk(2,2)
+ c28 = .5
+ c29 = .002053
+ c30 = .1
+ c31 = 3.0e-5
+!
+! Initialize further longwave constants referring to far wing
+! correction for overlap of H2O and trace gases; R&D refers to:
+!
+! Ramanathan, V. and P.Downey, 1986: A Nonisothermal
+! Emissivity and Absorptivity Formulation for Water Vapor
+! Journal of Geophysical Research, vol. 91., D8, pp 8649-8666
+!
+ fwcoef = .1 ! See eq(33) R&D
+ fwc1 = .30 ! See eq(33) R&D
+ fwc2 = 4.5 ! See eq(33) and eq(34) in R&D
+ fc1 = 2.6 ! See eq(34) R&D
+
+ IF ( wrf_dm_on_monitor() ) THEN
+ DO i = 10,99
+ INQUIRE ( i , OPENED = opened )
+ IF ( .NOT. opened ) THEN
+ cam_abs_unit = i
+ GOTO 2010
+ ENDIF
+ ENDDO
+ cam_abs_unit = -1
+ 2010 CONTINUE
+ ENDIF
+ CALL wrf_dm_bcast_bytes ( cam_abs_unit , IWORDSIZE )
+ IF ( cam_abs_unit < 0 ) THEN
+ CALL wrf_error_fatal ( 'module_ra_cam: radaeinit: Can not find unused fortran unit to read in lookup table.' )
+ ENDIF
+
+ IF ( wrf_dm_on_monitor() ) THEN
+ OPEN(cam_abs_unit,FILE='CAM_ABS_DATA', &
+ FORM='UNFORMATTED',STATUS='OLD',ERR=9010)
+ call wrf_debug(50,'reading CAM_ABS_DATA')
+ ENDIF
+
+#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * r8 )
+
+ IF ( wrf_dm_on_monitor() ) then
+ READ (cam_abs_unit,ERR=9010) ah2onw
+ READ (cam_abs_unit,ERR=9010) eh2onw
+ READ (cam_abs_unit,ERR=9010) ah2ow
+ READ (cam_abs_unit,ERR=9010) cn_ah2ow
+ READ (cam_abs_unit,ERR=9010) cn_eh2ow
+ READ (cam_abs_unit,ERR=9010) ln_ah2ow
+ READ (cam_abs_unit,ERR=9010) ln_eh2ow
+
+ endif
+
+ DM_BCAST_MACRO(ah2onw)
+ DM_BCAST_MACRO(eh2onw)
+ DM_BCAST_MACRO(ah2ow)
+ DM_BCAST_MACRO(cn_ah2ow)
+ DM_BCAST_MACRO(cn_eh2ow)
+ DM_BCAST_MACRO(ln_ah2ow)
+ DM_BCAST_MACRO(ln_eh2ow)
+
+ IF ( wrf_dm_on_monitor() ) CLOSE (cam_abs_unit)
+
+! Set up table of H2O saturation vapor pressures for use in calculation
+! effective path RH. Need separate table from table in wv_saturation
+! because:
+! (1. Path temperatures can fall below minimum of that table; and
+! (2. Abs/Emissivity tables are derived with RH for water only.
+!
+ tmin = nint(min_tp_h2o)
+ tmax = nint(max_tp_h2o)+1
+ itype = 0
+ do t = tmin, tmax
+! call gffgch(dble(t),estblh2o(t-tmin),itype)
+ tdbl = t
+ call gffgch(tdbl,estblh2o(t-tmin),itype)
+ end do
+
+ RETURN
+9010 CONTINUE
+ WRITE( errmess , '(A35,I4)' ) 'module_ra_cam: error reading unit ',cam_abs_unit
+ CALL wrf_error_fatal(errmess)
+end subroutine radaeini
+
+#endif
+!ldf end (05-01-2011).
+
+end MODULE module_ra_cam_support
</font>
</pre>