/dev/null 2>&1
- if [ $? != 0 ]; then
- sed 's/-cc=$(SCC)//' configure.wrf > configure.wrf.edit
- mv configure.wrf.edit configure.wrf
- fi
- rm ${foo} ${foo}.o 2> /dev/null
- mpif90 -f90=$SFC -o ${foo} ${foo}.f > /dev/null 2>&1
- if [ $? != 0 ]; then
- sed 's/-f90=$(SFC)//' configure.wrf > configure.wrf.edit
- mv configure.wrf.edit configure.wrf
- fi
- rm ${foo} ${foo}.o 2> /dev/null
- fi
- fi
-
- if [ -e $NETCDF/lib/libnetcdf.a -a "$SFC" != "" -a "$SCC" != "" -a "$CCOMP" != "" ]; then
-
- SFC_MULTI_ABI=0
- SCC_MULTI_ABI=0
- CCOMP_MULTI_ABI=0
- CROSS_COMPILING=0
-
- echo
- echo Testing for NetCDF, C and Fortran compiler
- echo
-
- ar p $NETCDF/lib/libnetcdf.a `ar t $NETCDF/lib/libnetcdf.a | grep -E '\.o' | head -n 1 | sed 's/://'` > ${foo}.o
- netcdf_arch="`file ${foo}.o | grep -o -E '[0-9]{2}-bit|i386'`"
- rm ${foo}.o
-
- $SFC -o ${foo} ${foo}.f > /dev/null 2>&1
- SFC_arch="`file ${foo} | grep -o -E '[0-9]{2}-bit|i386'`"
- rm ${foo} ${foo}.o 2> /dev/null
-
- $SCC -o ${foo} ${foo}.c > /dev/null 2>&1
- SCC_arch="`file ${foo} | grep -o -E '[0-9]{2}-bit|i386'`"
- CCOMP_arch=$SCC_arch
- rm ${foo} ${foo}.o 2> /dev/null
-
- if [ "$SCC" != "$CCOMP" ]; then
- $CCOMP -o ${foo} ${foo}.c > /dev/null 2>&1
- CCOMP_arch="`file ${foo} | grep -o -E '[0-9]{2}-bit|i386'`"
- rm ${foo} ${foo}.o 2> /dev/null
- fi
-
- if [ "$SFC_arch" = "" -o "$SCC_arch" = "" -o "$CCOMP_arch" = "" ]; then
- echo " One of compilers testing failed!"
- echo " Please check your compiler"
- echo
- rm -f ${foo} ${foo}.[cfo] 2> /dev/null
- exit
- else
- cp configure.wrf configure.wrf.edit
- fi
-
- case $netcdf_arch in
-
- 32-bit|i386 )
-
- if [ "$SFC_arch" = "64-bit" ] ; then
- CROSS_COMPILING=1
- $SFC -m32 -o ${foo} ${foo}.f > /dev/null 2>&1
- if [ $? = 0 ]; then
- SFC_MULTI_ABI=1
- sed '/^SFC.*=/s/$/ -m32/' configure.wrf.edit > configure.wrf.tmp
- mv configure.wrf.tmp configure.wrf.edit
- fi
- fi
- if [ "$SCC_arch" = "64-bit" ] ; then
- CROSS_COMPILING=1
- $SCC -m32 -o ${foo} ${foo}.c > /dev/null 2>&1
- if [ $? = 0 ]; then
- SCC_MULTI_ABI=1
- sed '/^SCC.*=/s/$/ -m32/' configure.wrf.edit > configure.wrf.tmp
- mv configure.wrf.tmp configure.wrf.edit
- fi
- fi
-
- if [ "$CCOMP_arch" = "64-bit" ] ; then
- CROSS_COMPILING=1
- if [ "$CCOMP" != "$SCC" ]; then
- $CCOMP -m32 -o ${foo} ${foo}.c > /dev/null 2>&1
- if [ $? = 0 ]; then
- CCOMP_MULTI_ABI=1
- sed '/^CCOMP/ s/$/ -m32/' configure.wrf.edit > configure.wrf.tmp
- mv configure.wrf.tmp configure.wrf.edit
- fi
- else
- CCOMP_MULTI_ABI=1
- sed '/^CCOMP/ s/$/ -m32/' configure.wrf.edit > configure.wrf.tmp
- mv configure.wrf.tmp configure.wrf.edit
- fi
- fi
-
- if [ $CROSS_COMPILING -eq 1 ] ; then
- echo NOTE:
- echo This installation of NetCDF is 32-bit
- if [ \( $SFC_MULTI_ABI -ne 1 -a "$SFC_arch" = "64-bit" \) \
- -o \( $SCC_MULTI_ABI -ne 1 -a "$SCC_arch" = "64-bit" \) \
- -o \( $CCOMP_MULTI_ABI -ne 1 -a "$CCOMP_arch" = "64-bit" \) ] ; then
- rm configure.wrf.edit
- echo One of compilers is 64-bit and doesn\'t support cross-compiling.
- echo Please check your NETCDF lib and compiler
- else
- echo -m32 is appended to configure.wrf
- echo It will be forced to build in 32-bit.
- echo If you don\'t want 32-bit binaries, please use 64-bit NetCDF, and re-run the configure script.
- fi
- fi
- ;;
-
- 64-bit )
-
- if [ "$SFC_arch" = "32-bit" -o "$SFC_arch" = "i386" ] ; then
- CROSS_COMPILING=1
- $SFC -m64 -o ${foo} ${foo}.f > /dev/null 2>&1
- if [ $? = 0 ]; then
- SFC_MULTI_ABI=1
- sed '/^SFC.*=/s/$/ -m64/' configure.wrf.edit > configure.wrf.tmp
- mv configure.wrf.tmp configure.wrf.edit
- fi
- fi
- if [ "$SCC_arch" = "32-bit" -o "$SCC_arch" = "i386" ] ; then
- CROSS_COMPILING=1
- $SCC -m64 -o ${foo} ${foo}.c > /dev/null 2>&1
- if [ $? = 0 ]; then
- SCC_MULTI_ABI=1
- sed '/^SCC.*=/s/$/ -m64/' configure.wrf.edit > configure.wrf.tmp
- mv configure.wrf.tmp configure.wrf.edit
- fi
- fi
-
- if [ "$CCOMP_arch" = "32-bit" -o "$CCOMP_arch" = "i386" ] ; then
- CROSS_COMPILING=1
- if [ "$CCOMP" != "$SCC" ]; then
- $CCOMP -m64 -o ${foo} ${foo}.c > /dev/null 2>&1
- if [ $? = 0 ]; then
- CCOMP_MULTI_ABI=1
- sed '/^CCOMP/ s/$/ -m64/' configure.wrf.edit > configure.wrf.tmp
- mv configure.wrf.tmp configure.wrf.edit
- fi
- else
- CCOMP_MULTI_ABI=1
- sed '/^CCOMP/ s/$/ -m64/' configure.wrf.edit > configure.wrf.tmp
- mv configure.wrf.tmp configure.wrf.edit
- fi
- fi
-
- if [ $CROSS_COMPILING -eq 1 ] ; then
- echo NOTE:
- echo This installation of NetCDF is 64-bit
- if [ \( $SFC_MULTI_ABI -ne 1 -a "$SFC_arch" != "64-bit" \) \
- -o \( $SCC_MULTI_ABI -ne 1 -a "$SCC_arch" != "64-bit" \) \
- -o \( $CCOMP_MULTI_ABI -ne 1 -a "$CCOMP_arch" != "64-bit" \) ]; then
- rm configure.wrf.edit
- echo One of Compilers is 32-bit and doesn\'t support cross-compiling.
- echo Please check your NetCDF lib and compiler
- else
- echo -m64 is appended to configure.wrf
- echo It will be forced to build in 64-bit.
- echo If you don\'t want 64-bit binaries, please use 32-bit NetCDF, and re-run the configure script.
- fi
- fi
- ;;
- esac
-
- if [ -e configure.wrf.edit ]; then
- mv configure.wrf.edit configure.wrf
- fi
-
- if [ $CROSS_COMPILING -eq 0 ] ; then
- echo "This installation of NetCDF is $netcdf_arch"
- echo " C compiler is $SCC_arch"
- echo " Fortran compiler is $SFC_arch"
- echo " It will build in $netcdf_arch"
- fi
- echo
- fi
- rm -f ${foo} ${foo}.[cfo] 2> /dev/null
-fi
-
-# testing for Fortran 2003 IEEE features
-make fortran_2003_ieee_test > tools/fortran_2003_ieee_test.log 2>&1
-rm -f tools/fortran_2003_ieee_test.log
-retval=-1
-if [ -f tools/fortran_2003_ieee_test.exe ] ; then
- retval=0
-fi
-if [ $retval -ne 0 ] ; then
- sed -e '/^ARCH_LOCAL/s/$/ -DNO_IEEE_MODULE/' configure.wrf > configure.wrf.edit
- mv configure.wrf.edit configure.wrf
- echo " "
- echo " "
- echo "************************** W A R N I N G ************************************"
- echo " "
- echo "There are some IEEE Fortran 2003 features in WRF that your compiler does not"
- echo "recognize. The IEEE function calls have been removed."
- echo " "
- echo "*****************************************************************************"
-fi
-
-# testing for Fortran 2003 ISO_C features
-make fortran_2003_iso_c_test > tools/fortran_2003_iso_c_test.log 2>&1
-rm -f tools/fortran_2003_iso_c_test.log
-retval=-1
-if [ -f tools/fortran_2003_iso_c_test.exe ] ; then
- retval=0
-fi
-if [ $retval -ne 0 ] ; then
- sed -e '/^ARCH_LOCAL/s/$/ -DNO_ISO_C_SUPPORT/' configure.wrf > configure.wrf.edit
- mv configure.wrf.edit configure.wrf
- echo " "
- echo " "
- echo "************************** W A R N I N G ************************************"
- echo " "
- echo "There are some Fortran 2003 features in WRF that your compiler does not recognize"
- echo "The routines that utilize ISO_C support have been stubbed out. "
- echo "That may not be enough."
- echo " "
- echo "*****************************************************************************"
-fi
-
-# testing for Fortran 2003 FLUSH features
-make fortran_2003_flush_test > tools/fortran_2003_flush_test.log 2>&1
-rm -f tools/fortran_2003_flush_test.log
-retval=-1
-if [ -f tools/fortran_2003_flush_test.exe ] ; then
- retval=0
-fi
-if [ $retval -ne 0 ] ; then
- make fortran_2003_fflush_test > tools/fortran_2003_fflush_test.log 2>&1
- rm -f tools/fortran_2003_fflush_test.log
- retval=-1
- if [ -f tools/fortran_2003_fflush_test.exe ] ; then
- retval=0
- fi
- if [ $retval -eq 0 ] ; then
- sed -e '/^ARCH_LOCAL/s/$/ -DUSE_FFLUSH/' configure.wrf > configure.wrf.edit
- mv configure.wrf.edit configure.wrf
- echo " "
- echo " "
- echo "************************** W A R N I N G ************************************"
- echo " "
- echo "There are some Fortran 2003 features in WRF that your compiler does not recognize"
- echo "The standard FLUSH routine has been replaced by FFLUSH."
- echo "That may not be enough."
- echo " "
- echo "*****************************************************************************"
- fi
- if [ $retval -ne 0 ] ; then
- sed -e '/^ARCH_LOCAL/s/$/ -DNO_FLUSH_SUPPORT/' configure.wrf > configure.wrf.edit
- mv configure.wrf.edit configure.wrf
- echo " "
- echo " "
- echo "************************** W A R N I N G ************************************"
- echo " "
- echo "There are some Fortran 2003 features in WRF that your compiler does not recognize"
- echo "The standard FLUSH routine has been stubbed out."
- echo "That may not be enough."
- echo " "
- echo "*****************************************************************************"
- fi
-fi
-
-# testing for Fortran 2008 intrinsic gamma function
-make fortran_2008_gamma_test > tools/fortran_2008_gamma.log 2>&1
-rm -f tools/fortran_2008_gamma.log
-retval=-1
-if [ -f tools/fortran_2008_gamma_test.exe ] ; then
- retval=0
-fi
-if [ $retval -ne 0 ] ; then
- sed -e '/^ARCH_LOCAL/s/$/ -DNO_GAMMA_SUPPORT/' configure.wrf > configure.wrf.edit
- mv configure.wrf.edit configure.wrf
- echo " "
- echo " "
- echo "************************** W A R N I N G ************************************"
- echo " "
- echo "There are some Fortran 2008 features in WRF that your compiler does not recognize"
- echo "The intrinsic gamma function is not available, required by some schemes."
- echo "That code is stubbbed out, and those schemes are unavailable at run-time."
- echo " "
- echo "*****************************************************************************"
-fi
-
-# testing for location of rpc/types.h file, used in landuse
-if [ -f /usr/include/rpc/types.h ] ; then
- sed -e '/^ARCH_LOCAL/s/$/ -DRPC_TYPES=1/' configure.wrf > configure.wrf.edit
- mv configure.wrf.edit configure.wrf
-echo standard location of RPC
-elif [ -f /usr/include/tirpc/rpc/types.h ] ; then
- sed -e '/^ARCH_LOCAL/s/$/ -DRPC_TYPES=2/' configure.wrf > configure.wrf.edit
- mv configure.wrf.edit configure.wrf
-echo newer location of RPC
-else
- echo "************************** W A R N I N G ************************************"
- echo " "
- echo "The moving nest option is not available due to missing rpc/types.h file."
- echo "Copy landread.c.dist to landread.c in share directory to bypass compile error."
- echo " "
- echo "*****************************************************************************"
-fi
-
-# testing for netcdf4 IO features
-if [ -n "$NETCDF4" ] ; then
- if [ $NETCDF4 -eq 1 ] ; then
- make nc4_test > tools/nc4_test.log 2>&1
- retval=-1
- if [ -f tools/nc4_test.exe ] ; then
- retval=0
- rm -f tools/nc4_test.log
- fi
- if [ $retval -ne 0 ] ; then
- echo "************************** W A R N I N G ************************************"
- echo "NETCDF4 IO features are requested, but this installation of NetCDF "
- echo " $NETCDF"
- echo "DOES NOT support these IO features. "
- echo
- echo "Please make sure NETCDF version is 4.1.3 or later and was built with "
- echo "--enable-netcdf4 "
- echo
- echo "OR set NETCDF_classic variable "
- echo " bash/ksh : export NETCDF_classic=1
- echo " csh : setenv NETCDF_classic 1
- echo
- echo "Then re-run this configure script "
- echo
- echo "!!! configure.wrf has been REMOVED !!!"
- echo
- echo "*****************************************************************************"
- rm -f configure.wrf
- else
- echo "*****************************************************************************"
- echo "This build of WRF will use NETCDF4 with HDF5 compression"
- echo "*****************************************************************************"
- echo " "
- fi
- fi
-else
- echo "*****************************************************************************"
- echo "This build of WRF will use classic (non-compressed) NETCDF format"
- echo "*****************************************************************************"
- echo " "
-fi
diff --git a/UTIL/wrfcmaq_twoway_coupler/dyn_em/module_first_rk_step_part1.F b/UTIL/wrfcmaq_twoway_coupler/dyn_em/module_first_rk_step_part1.F
deleted file mode 100644
index 6dbaace9ca..0000000000
--- a/UTIL/wrfcmaq_twoway_coupler/dyn_em/module_first_rk_step_part1.F
+++ /dev/null
@@ -1,1742 +0,0 @@
-!WRF:MEDIATION_LAYER:SOLVER
-
-#define BENCH_START(A)
-#define BENCH_END(A)
-
-MODULE module_first_rk_step_part1
-
-CONTAINS
-
- SUBROUTINE first_rk_step_part1 ( grid , config_flags &
- , moist , moist_tend &
- , chem , chem_tend &
- , tracer, tracer_tend &
- , scalar , scalar_tend &
- , fdda3d, fdda2d &
- , aerod &
- , ru_tendf, rv_tendf &
- , rw_tendf, t_tendf &
- , ph_tendf, mu_tendf &
- , tke_tend &
- , adapt_step_flag , curr_secs &
- , psim , psih , gz1oz0 , chklowq &
- , cu_act_flag , hol , th_phy &
- , pi_phy , p_phy , t_phy &
- , dz8w , p8w , t8w &
- , ids, ide, jds, jde, kds, kde &
- , ims, ime, jms, jme, kms, kme &
- , ips, ipe, jps, jpe, kps, kpe &
- , imsx,imex,jmsx,jmex,kmsx,kmex &
- , ipsx,ipex,jpsx,jpex,kpsx,kpex &
- , imsy,imey,jmsy,jmey,kmsy,kmey &
- , ipsy,ipey,jpsy,jpey,kpsy,kpey &
- , k_start , k_end &
- , f_flux &
- , aerocu &
- , restart_flag &
- , feedback_is_ready &
- )
- USE module_state_description
- USE module_model_constants
- USE module_domain, ONLY : domain, domain_clock_get, get_ijk_from_subgrid
- USE module_configure, ONLY : grid_config_rec_type, model_config_rec
- USE module_radiation_driver, ONLY : pre_radiation_driver, radiation_driver
- USE module_surface_driver, ONLY : surface_driver
- USE module_cumulus_driver, ONLY : cumulus_driver
- USE module_shallowcu_driver, ONLY : shallowcu_driver
- USE module_pbl_driver, ONLY : pbl_driver
- USE module_fr_fire_driver_wrf, ONLY : fire_driver_em_step
- USE module_fddagd_driver, ONLY : fddagd_driver
- USE module_em, ONLY : init_zero_tendency
- USE module_force_scm
- USE module_convtrans_prep
- USE module_big_step_utilities_em, ONLY : phy_prep
-!use module_scalar_tables
-#ifdef DM_PARALLEL
- USE module_dm, ONLY : local_communicator, mytask, ntasks, ntasks_x, ntasks_y, local_communicator_periodic, wrf_dm_maxval
- USE module_comm_dm, ONLY : halo_em_phys_a_sub,halo_em_fdda_sfc_sub,halo_pwp_sub,halo_em_chem_e_3_sub, &
- halo_em_chem_e_5_sub, halo_em_hydro_noahmp_sub
-#if ( WRFPLUS == 1 )
- USE module_comm_dm, ONLY : halo_em_phys_a_bl_surf_sub
-#endif
-#endif
- USE module_utility
- IMPLICIT NONE
-
- TYPE ( domain ), INTENT(INOUT) :: grid
- TYPE ( grid_config_rec_type ), INTENT(IN) :: config_flags
- TYPE(WRFU_Time) :: currentTime
-
- INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- imsx,imex,jmsx,jmex,kmsx,kmex, &
- ipsx,ipex,jpsx,jpex,kpsx,kpex, &
- imsy,imey,jmsy,jmey,kmsy,kmey, &
- ipsy,ipey,jpsy,jpey,kpsy,kpey
-
-
- LOGICAL ,INTENT(IN) :: adapt_step_flag
- REAL, INTENT(IN) :: curr_secs
-
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_moist),INTENT(INOUT) :: moist
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_moist),INTENT(INOUT) :: moist_tend
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_chem),INTENT(INOUT) :: chem
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_chem),INTENT(INOUT) :: chem_tend
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_tracer),INTENT(INOUT) :: tracer
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_tracer),INTENT(INOUT) :: tracer_tend
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_scalar),INTENT(INOUT) :: scalar
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_scalar),INTENT(INOUT) :: scalar_tend
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_fdda3d),INTENT(INOUT) :: fdda3d
- REAL ,DIMENSION(ims:ime,1:1,jms:jme,num_fdda2d),INTENT(INOUT) :: fdda2d
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_aerod),INTENT(INOUT) :: aerod
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_aerocu),INTENT(INOUT) ::aerocu
- REAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: psim
- REAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: psih
- REAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: gz1oz0
- REAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: chklowq
- LOGICAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: cu_act_flag
- REAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: hol
-
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: th_phy
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: pi_phy
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: p_phy
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: t_phy
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: dz8w
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: p8w
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: t8w
-
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: ru_tendf
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: rv_tendf
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: rw_tendf
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: ph_tendf
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: t_tendf
- REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: tke_tend
-
- REAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: mu_tendf
-
- INTEGER, INTENT(IN) :: k_start, k_end
- LOGICAL, INTENT(IN), OPTIONAL :: f_flux
-
- LOGICAL, INTENT(IN) :: restart_flag
-
- LOGICAL, INTENT(IN) :: feedback_is_ready ! For WRF-CMAQ coupled model, indicates feedback information is available
-
-! Local
- real :: HYDRO_dt
- REAL, DIMENSION( ims:ime, jms:jme ) :: exch_temf ! 1/7/09 WA
-
- REAL, DIMENSION( ims:ime, jms:jme ) :: ht_loc, mixht
- REAL, DIMENSION( ims:ime, jms:jme ) :: hpbl_hold
- INTEGER :: i, j, istart, iend, jstart, jend
-
-
-
- INTEGER :: ij
- INTEGER num_roof_layers
- INTEGER num_wall_layers
- INTEGER num_road_layers
- INTEGER iswater
- LOGICAL :: l_flux
- INTEGER :: isurban
- INTEGER rk_step
- INTEGER :: yr, month, day, hr, minute, sec, rc
- CHARACTER*80 :: mesg
-
- INTEGER :: sids , side , sjds , sjde , skds , skde , &
- sims , sime , sjms , sjme , skms , skme , &
- sips , sipe , sjps , sjpe , skps , skpe
-
- CHARACTER (LEN=256) :: mminlu
- CHARACTER (LEN=1000) :: message
- LOGICAL :: do_bioe
-
-! Added flag to use MEGANv2.1 file BJG 3/28/19
- LOGICAL :: do_meganfile
-
-#if ( WRF_DFI_RADAR == 1 )
- INTEGER do_capsupress ! =1 do CAP supress, other = don't
-#endif
-
- CALL get_ijk_from_subgrid ( grid , &
- sids, side, sjds, sjde, skds, skde, &
- sims, sime, sjms, sjme, skms, skme, &
- sips, sipe, sjps, sjpe, skps, skpe )
-
- ! initialize all tendencies to zero in order to update physics
- ! tendencies first (separate from dry dynamics).
-
- l_flux=.FALSE.
- if (present(f_flux)) l_flux=f_flux
-
- rk_step = 1
-
-BENCH_START(init_zero_tend_tim)
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
-
- DO ij = 1 , grid%num_tiles
-
- CALL wrf_debug ( 200 , ' call init_zero_tendency' )
- CALL init_zero_tendency ( ru_tendf, rv_tendf, rw_tendf, &
- ph_tendf, t_tendf, tke_tend, &
- mu_tendf, &
- moist_tend,chem_tend,scalar_tend, &
- tracer_tend,num_tracer, &
- num_moist,num_chem,num_scalar, &
- rk_step, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
-
- END DO
- !$OMP END PARALLEL DO
-BENCH_END(init_zero_tend_tim)
-
-#ifdef DM_PARALLEL
-# include "HALO_EM_PHYS_A.inc"
-#endif
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
-
- CALL wrf_debug ( 200 , ' call phy_prep' )
- CALL phy_prep ( config_flags, &
- grid%mut, grid%muu, grid%muv, &
- grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
- grid%u_2, grid%v_2, grid%p, grid%pb, grid%alt, &
- grid%ph_2, grid%phb, grid%t_2, moist, num_moist, &
- grid%rho,th_phy, grid%th_phy_m_t0, &
- p_phy, pi_phy, grid%u_phy, grid%v_phy, &
- p8w, t_phy, t8w, grid%z, grid%z_at_w, dz8w, &
- grid%p_hyd, grid%p_hyd_w, grid%dnw, &
- grid%fnm, grid%fnp, grid%znw, grid%p_top, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
- ENDDO
- !$OMP END PARALLEL DO
-
-BENCH_END(phy_prep_tim)
-
-! radiation
- CALL domain_clock_get( grid, current_time=currentTime, &
- current_timestr=mesg )
- CALL WRFU_TimeGet( currentTime, YY=yr, dayOfYear=day, H=hr, M=minute, S=sec, rc=rc)
- IF( rc/= WRFU_SUCCESS)THEN
- CALL wrf_error_fatal('WRFU_TimeGet failed')
- ENDIF
-
-! this driver is only needed to handle non-local shadowing effects
- CALL pre_radiation_driver ( grid, config_flags &
- & ,itimestep=grid%itimestep, ra_call_offset=grid%ra_call_offset &
- & ,XLAT=grid%xlat, XLONG=grid%xlong, GMT=grid%gmt &
- & ,julian=grid%julian, xtime=grid%xtime, RADT=grid%radt &
- & ,STEPRA=grid%stepra &
- & ,ht=grid%ht,dx=grid%dx,dy=grid%dy &
- & ,dx2d=grid%dx2d,area2d=grid%area2d &
- & ,sina=grid%sina,cosa=grid%cosa &
- & ,shadowmask=grid%shadowmask,slope_rad=config_flags%slope_rad &
- & ,topo_shading=config_flags%topo_shading &
- & ,shadlen=config_flags%shadlen,ht_shad=grid%ht_shad,ht_loc=ht_loc &
- & ,ht_shad_bxs=grid%ht_shad_bxs, ht_shad_bxe=grid%ht_shad_bxe &
- & ,ht_shad_bys=grid%ht_shad_bys, ht_shad_bye=grid%ht_shad_bye &
- & ,nested=config_flags%nested, min_ptchsz=grid%min_ptchsz &
- & ,spec_bdy_width=config_flags%spec_bdy_width &
- ! indexes
- & ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &
- & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
- & ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe &
- & ,i_start=grid%i_start,i_end=min(grid%i_end, ide-1) &
- & ,j_start=grid%j_start,j_end=min(grid%j_end, jde-1) &
- & ,kts=k_start, kte=min(k_end,kde-1) &
- & ,num_tiles=grid%num_tiles )
-
- CALL wrf_debug ( 200 , ' call radiation_driver' )
-BENCH_START(rad_driver_tim)
-
- CALL radiation_driver( &
- & p_top=grid%p_top & !DJW 140312 added p_top for vertical nesting
- & ,ACFRCV=grid%acfrcv ,ACFRST=grid%acfrst ,ALBEDO=grid%albedo &
- & ,CFRACH=grid%cfrach ,CFRACL=grid%cfracl ,CFRACM=grid%cfracm &
- & ,CUPPT=grid%cuppt ,CZMEAN=grid%czmean ,DT=grid%dt &
- & ,DZ8W=dz8w ,EMISS=grid%emiss ,GLW=grid%glw &
- & ,GMT=grid%gmt ,GSW=grid%gsw ,HBOT=grid%hbot &
- & ,HTOP=grid%htop ,HBOTR=grid%hbotr ,HTOPR=grid%htopr &
- & ,ICLOUD=config_flags%icloud &
- & ,ITIMESTEP=grid%itimestep,JULDAY=grid%julday , JULIAN=grid%julian &
- & ,JULYR=grid%julyr ,LW_PHYSICS=config_flags%ra_lw_physics &
- & ,NCFRCV=grid%ncfrcv ,NCFRST=grid%ncfrst ,NPHS=1 &
- & ,o3input=config_flags%o3input ,O3rad=grid%o3rad &
- & ,aer_opt=config_flags%aer_opt ,aerod=aerod(:,:,:,P_ocarbon:P_upperaer) &
- & ,swint_opt=config_flags%swint_opt &
- & ,solar_opt=config_flags%solar_diagnostics &
- & ,P8W=grid%p_hyd_w ,P=grid%p_hyd ,PI=pi_phy &
- & ,RADT=grid%radt ,RA_CALL_OFFSET=grid%ra_call_offset &
- & ,RHO=grid%rho ,RLWTOA=grid%rlwtoa &
- & ,RSWTOA=grid%rswtoa ,RTHRATEN=grid%rthraten &
- & ,RTHRATENLW=grid%rthratenlw ,RTHRATENSW=grid%rthratensw &
- & ,RTHRATENLWC=grid%rthratenlwc ,RTHRATENSWC=grid%rthratenswc &
- & ,SNOW=grid%snow ,STEPRA=grid%stepra ,SWDOWN=grid%swdown &
- & ,SWDOWNC=grid%swdownc ,SW_PHYSICS=config_flags%ra_sw_physics &
- & ,T8W=t8w ,T=grid%t_phy ,TAUCLDC=grid%taucldc &
- & ,TAUCLDI=grid%taucldi ,TSK=grid%tsk ,VEGFRA=grid%vegfra &
- & ,WARM_RAIN=grid%warm_rain ,XICE=grid%xice ,XLAND=grid%xland &
- & ,XLAT=grid%xlat ,XLONG=grid%xlong ,YR=yr &
- ! SSiB LSM radiation components (fds 06/2010)
- & ,ALSWVISDIR=grid%alswvisdir ,ALSWVISDIF=grid%alswvisdif & !ssib
- & ,ALSWNIRDIR=grid%alswnirdir ,ALSWNIRDIF=grid%alswnirdif & !ssib
- & ,SWVISDIR=grid%swvisdir ,SWVISDIF=grid%swvisdif & !ssib
- & ,SWNIRDIR=grid%swnirdir ,SWNIRDIF=grid%swnirdif & !ssib
- & ,SF_SURFACE_PHYSICS=config_flags%sf_surface_physics & !ssib
-! WRF-solar and aerosol variables from jararias 2013/8 and 2013/11
- & ,SWDDIR=grid%swddir,SWDDNI=grid%swddni,SWDDIF=grid%swddif &
- & ,SWDDIRC=grid%swddirc, SWDDNIC=grid%swddnic &
- & ,Gx=grid%Gx,Bx=grid%Bx,gg=grid%gg,bb=grid%bb &
- & ,swdown_ref=grid%swdown_ref,swddir_ref=grid%swddir_ref &
- & ,coszen_ref=grid%coszen_ref &
- & ,aer_type=config_flags%aer_type &
- & ,aer_aod550_opt=config_flags%aer_aod550_opt,aer_aod550_val=config_flags%aer_aod550_val &
- & ,aer_angexp_opt=config_flags%aer_angexp_opt,aer_angexp_val=config_flags%aer_angexp_val &
- & ,aer_ssa_opt=config_flags%aer_ssa_opt,aer_ssa_val=config_flags%aer_ssa_val &
- & ,aer_asy_opt=config_flags%aer_asy_opt,aer_asy_val=config_flags%aer_asy_val &
- & ,aod5502d=grid%aod5502d,angexp2d=grid%angexp2d,aerssa2d=grid%aerssa2d &
- & ,aerasy2d=grid%aerasy2d,aod5503d=grid%aod5503d &
- & ,taod5502d=grid%taod5502d,taod5503d=grid%taod5503d & ! Trude
-!Optional solar variables
- & ,DECLINX=grid%declin ,SOLCONX=grid%solcon ,COSZEN=grid%coszen ,HRANG=grid%hrang &
- & , CEN_LAT=grid%cen_lat &
- & ,Z=grid%z &
- & ,ALEVSIZ=grid%alevsiz, no_src_types=grid%no_src_types &
- & ,LEVSIZ=grid%levsiz, N_OZMIXM=num_ozmixm &
- & ,N_AEROSOLC=num_aerosolc &
- & ,PAERLEV=grid%paerlev ,ID=grid%id &
- & ,CAM_ABS_DIM1=grid%cam_abs_dim1, CAM_ABS_DIM2=grid%cam_abs_dim2 &
- & ,CAM_ABS_FREQ_S=grid%cam_abs_freq_s &
- & ,XTIME=grid%xtime &
- ,CURR_SECS=curr_secs, ADAPT_STEP_FLAG=adapt_step_flag &
-#if ( EM_CORE == 1)
- & ,swdown2=grid%swdown2, swddni2=grid%swddni2 & ! FARMS coupling
- & ,swddif2=grid%swddif2, swddir2=grid%swddir2 & ! FARMS coupling
- & ,swdownc2=grid%swdownc2, swddnic2=grid%swddnic2 & ! FARMS coupling
-#endif
-!BSINGH - For WRFCuP scheme
- & ,CU_PHYSICS=config_flags%cu_physics & !CuP, wig 5-Oct-2006
- & ,SHALLOWCU_FORCED_RA=config_flags%shallowcu_forced_ra & !CuP, wig
- & ,CUBOT=grid%cubot, CUTOP=grid%cutop & !CuP, wig 9-Oct-2006
- & ,CLDFRA_CUP=grid%cldfra_cup & !CuP, wig 1-Oct-2006
- & ,SHALL=grid%shall & !CuP, wig 4-Feb-2008
-!BSINGH - ENDS
- ! indexes
- & ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &
- & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
- & ,i_start=grid%i_start,i_end=min(grid%i_end, ide-1) &
- & ,j_start=grid%j_start,j_end=min(grid%j_end, jde-1) &
- & ,kts=k_start, kte=min(k_end,kde-1) &
- & ,num_tiles=grid%num_tiles &
- ! Optional
-!JJS 20101020 vvvvv
-#if ( WRF_CHEM == 1)
- & , CHEM=chem &
- & , AOD_OUT=grid%aod_out &
- & , AOD2D_OUT=grid%aod2d_out & !goddardrad
- & , ATOP2D_OUT=grid%atop2d_out & !goddardrad
- & , CHEM_OPT=config_flags%chem_opt &
- & , GSFCRAD_GOCART_COUPLING=config_flags%gsfcrad_gocart_coupling &
-#endif
- & , TLWDN=grid%tlwdn, TLWUP=grid%tlwup & ! goddard schemes
- & , SLWDN=grid%slwdn, SLWUP=grid%slwup & ! goddard schemes
- & , TSWDN=grid%tswdn, TSWUP=grid%tswup & ! goddard schemes
- & , SSWDN=grid%sswdn, SSWUP=grid%sswup & ! goddard schemes
- & , RE_CLOUD_GSFC=grid%re_cloud_gsfc & ! goddard schemes
- & , RE_RAIN_GSFC=grid%re_rain_gsfc & ! goddard schemes
- & , RE_ICE_GSFC=grid%re_ice_gsfc & ! goddard schemes
- & , RE_SNOW_GSFC=grid%re_snow_gsfc & ! goddard schemes
- & , RE_GRAUPEL_GSFC=grid%re_graupel_gsfc & ! goddard schemes
- & , RE_HAIL_GSFC=grid%re_hail_gsfc & ! goddard schemes
- & , COD2D_OUT=grid%cod2d_out & ! goddardrad
- & , CTOP2D_OUT=grid%ctop2d_out & ! goddardrad
-!JJS 20101020 ^^^^^
-!ZCX+ cloud fraction for CLWRF
- & , CLDT=grid%cldt, ZNU=grid%znu &
-!ZCX-
- & , CLDFRA=grid%cldfra, CLDFRA_MP_ALL=grid%cldfra_mp_all &
- & , CCLDFRA=grid%ccldfra &
- & , QCCONV=grid%qcconv, QICONV=grid%qiconv &
- & , BMJ_RAD_FEEDBACK=config_flags%bmj_rad_feedback &
- & , LRADIUS=grid%LRADIUS,IRADIUS=grid%IRADIUS & !BSINGH(01/22/2014)
- & , CLDFRA_DP=grid%cldfra_dp & ! ckay for subgrid cloud
- & , CLDFRA_SH=grid%cldfra_sh &
- & , icloud_bl=config_flags%icloud_bl &
- & , cldovrlp=config_flags%cldovrlp & ! J. Henderson AER: cldovrlp namelist value
- & , qc_bl=grid%qc_bl,qi_bl=grid%qi_bl,cldfra_bl=grid%cldfra_bl&
- & , re_cloud=grid%re_cloud, re_ice=grid%re_ice, re_snow=grid%re_snow & ! G. Thompson
- & , has_reqc=grid%has_reqc, has_reqi=grid%has_reqi, has_reqs=grid%has_reqs & ! G. Thompson
- & , PB=grid%pb &
- & , F_ICE_PHY=grid%f_ice_phy,F_RAIN_PHY=grid%f_rain_phy &
- & , F_QNC=F_QNC &
- & , QNC_CURR=scalar(ims,kms,jms,P_QNC) &
- & , QV=moist(ims,kms,jms,P_QV), F_QV=F_QV &
- & , QC=moist(ims,kms,jms,P_QC), F_QC=F_QC &
- & , QR=moist(ims,kms,jms,P_QR), F_QR=F_QR &
- & , QI=moist(ims,kms,jms,P_QI), F_QI=F_QI &
- & , QI2=moist(ims,kms,jms,P_QI2), F_QI2=F_QI2 & ! for P3
- & , QI3=moist(ims,kms,jms,P_QI3), F_QI3=F_QI3 & ! for Jensen ISHMAEL
- & , QS=moist(ims,kms,jms,P_QS), F_QS=F_QS &
- & , QG=moist(ims,kms,jms,P_QG), F_QG=F_QG &
- & , QH=moist(ims,kms,jms,P_QH), F_QH=F_QH & ! goddardrad
- & , QNDROP=scalar(ims,kms,jms,P_QNDROP), F_QNDROP=F_QNDROP &
- & ,QNIFA=scalar(ims,kms,jms,P_QNIFA),F_QNIFA=F_QNIFA & !Trude
- & ,QNWFA=scalar(ims,kms,jms,P_QNWFA),F_QNWFA=F_QNWFA & !Trude
- & ,qc_tot=grid%qc_tot, qi_tot=grid%qi_tot & ! Solar diag
- & ,ACSWUPT=grid%acswupt ,ACSWUPTC=grid%acswuptc &
- & ,ACSWDNT=grid%acswdnt ,ACSWDNTC=grid%acswdntc &
- & ,ACSWUPB=grid%acswupb ,ACSWUPBC=grid%acswupbc &
- & ,ACSWDNB=grid%acswdnb ,ACSWDNBC=grid%acswdnbc &
- & ,ACLWUPT=grid%aclwupt ,ACLWUPTC=grid%aclwuptc &
- & ,ACLWDNT=grid%aclwdnt ,ACLWDNTC=grid%aclwdntc &
- & ,ACLWUPB=grid%aclwupb ,ACLWUPBC=grid%aclwupbc &
- & ,ACLWDNB=grid%aclwdnb ,ACLWDNBC=grid%aclwdnbc &
- & ,SWUPT=grid%swupt,SWUPTC=grid%swuptc,SWUPTCLN=grid%swuptcln &
- & ,SWDNT=grid%swdnt,SWDNTC=grid%swdntc,SWDNTCLN=grid%swdntcln &
- & ,SWUPB=grid%swupb,SWUPBC=grid%swupbc,SWUPBCLN=grid%swupbcln &
- & ,SWDNB=grid%swdnb,SWDNBC=grid%swdnbc,SWDNBCLN=grid%swdnbcln &
- & ,LWUPT=grid%lwupt,LWUPTC=grid%lwuptc,LWUPTCLN=grid%lwuptcln &
- & ,LWDNT=grid%lwdnt,LWDNTC=grid%lwdntc,LWDNTCLN=grid%lwdntcln &
- & ,LWUPB=grid%lwupb,LWUPBC=grid%lwupbc,LWUPBCLN=grid%lwupbcln &
- & ,LWDNB=grid%lwdnb,LWDNBC=grid%lwdnbc,LWDNBCLN=grid%lwdnbcln &
- & ,LWCF=grid%lwcf &
- & ,SWCF=grid%swcf &
- & ,OLR=grid%olr &
- & ,AERODM=grid%aerodm, PINA=grid%pina, AODTOT=grid%aodtot &
- & ,OZMIXM=grid%ozmixm, PIN=grid%pin &
- & ,M_PS_1=grid%m_ps_1, M_PS_2=grid%m_ps_2, AEROSOLC_1=grid%aerosolc_1 &
- & ,AEROSOLC_2=grid%aerosolc_2, M_HYBI0=grid%m_hybi &
- & ,ABSTOT=grid%abstot, ABSNXT=grid%absnxt, EMSTOT=grid%emstot &
- & ,RADTACTTIME=grid%radtacttime &
- & ,ICLOUD_CU=config_flags%ICLOUD_CU &
- & ,QC_CU=grid%QC_CU , QI_CU=grid%QI_CU &
- & ,CALC_CLEAN_ATM_DIAG=config_flags%calc_clean_atm_diag &
-#if (WRF_CHEM == 1)
- & ,AER_RA_FEEDBACK=config_flags%aer_ra_feedback &
- & ,PM2_5_DRY=grid%pm2_5_dry, PM2_5_WATER=grid%pm2_5_water &
- & ,PM2_5_DRY_EC=grid%pm2_5_dry_ec &
- & ,TAUAER300=grid%tauaer1, TAUAER400=grid%tauaer2 & ! jcb
- & ,TAUAER600=grid%tauaer3, TAUAER999=grid%tauaer4 & ! jcb
- & ,GAER300=grid%gaer1, GAER400=grid%gaer2, GAER600=grid%gaer3, GAER999=grid%gaer4 & ! jcb
- & ,WAER300=grid%waer1, WAER400=grid%waer2, WAER600=grid%waer3, WAER999=grid%waer4 & ! jcb
- & ,TAUAERlw1 =grid%tauaerlw1, TAUAERlw2=grid%tauaerlw2 &
- & ,TAUAERlw3 =grid%tauaerlw3, TAUAERlw4=grid%tauaerlw4 &
- & ,TAUAERlw5 =grid%tauaerlw5, TAUAERlw6=grid%tauaerlw6 &
- & ,TAUAERlw7 =grid%tauaerlw7, TAUAERlw8=grid%tauaerlw8 &
- & ,TAUAERlw9 =grid%tauaerlw9, TAUAERlw10=grid%tauaerlw10 &
- & ,TAUAERlw11 =grid%tauaerlw11, TAUAERlw12=grid%tauaerlw12 &
- & ,TAUAERlw13 =grid%tauaerlw13, TAUAERlw14=grid%tauaerlw14 &
- & ,TAUAERlw15 =grid%tauaerlw15, TAUAERlw16=grid%tauaerlw16 &
- & ,progn=config_flags%progn &
-#endif
- & ,slope_rad=config_flags%slope_rad,topo_shading=config_flags%topo_shading &
- & ,shadowmask=grid%shadowmask &
- & ,ht=grid%ht,dx=grid%dx,dy=grid%dy,dx2d=grid%dx2d,area2d=grid%area2d &
- & ,diffuse_frac=grid%diffuse_frac &
- & ,obscur=grid%ECOBSC, mask=grid%ECMASK &
- & ,elat_track=grid%elat_track,elon_track=grid%elon_track &
- & ,SW_ECLIPSE=config_flags%ra_sw_eclipse &
- & ,IS_CAMMGMP_USED = grid%is_CAMMGMP_used &
- & ,cw_rad=grid%cw_rad &
- & ,shcu_physics=config_flags%shcu_physics &
- & ,MP_PHYSICS=CONFIG_FLAGS%MP_PHYSICS &
- & ,EFCG=grid%EFCG,EFCS=grid%EFCS,EFIG=grid%EFIG &
- & ,EFIS=grid%EFIS,EFSG=grid%EFSG,aercu_opt=config_flags%aercu_opt &
- & ,EFSS=grid%EFSS,QS_CU=grid%QS_CU &
- & ,feedback_is_ready=feedback_is_ready &
-#if ( WRF_CMAQ == 1)
- & ,mass_ws_i=grid%mass_ws_i &
- & ,mass_ws_j=grid%mass_ws_j &
- & ,mass_ws_k=grid%mass_ws_k &
- & ,mass_in_i=grid%mass_in_i &
- & ,mass_in_j=grid%mass_in_j &
- & ,mass_in_k=grid%mass_in_k &
- & ,mass_ec_i=grid%mass_ec_i &
- & ,mass_ec_j=grid%mass_ec_j &
- & ,mass_ec_k=grid%mass_ec_k &
- & ,mass_ss_i=grid%mass_ss_i &
- & ,mass_ss_j=grid%mass_ss_j &
- & ,mass_ss_k=grid%mass_ss_k &
- & ,mass_h2o_i=grid%mass_h2o_i &
- & ,mass_h2o_j=grid%mass_h2o_j &
- & ,mass_h2o_k=grid%mass_h2o_k &
- & ,dgn_i=grid%dgn_i &
- & ,dgn_j=grid%dgn_j &
- & ,dgn_k=grid%dgn_k &
- & ,sig_i=grid%sig_i &
- & ,sig_j=grid%sig_j &
- & ,sig_k=grid%sig_k &
- & ,sw_gtauxar_01=grid%sw_gtauxar_01 &
- & ,sw_gtauxar_02=grid%sw_gtauxar_02 &
- & ,sw_gtauxar_03=grid%sw_gtauxar_03 &
- & ,sw_gtauxar_04=grid%sw_gtauxar_04 &
- & ,sw_gtauxar_05=grid%sw_gtauxar_05 &
- & ,sw_ttauxar_01=grid%sw_ttauxar_01 &
- & ,sw_ttauxar_02=grid%sw_ttauxar_02 &
- & ,sw_ttauxar_03=grid%sw_ttauxar_03 &
- & ,sw_ttauxar_04=grid%sw_ttauxar_04 &
- & ,sw_ttauxar_05=grid%sw_ttauxar_05 &
- & ,sw_asy_fac_01=grid%sw_asy_fac_01 &
- & ,sw_asy_fac_02=grid%sw_asy_fac_02 &
- & ,sw_asy_fac_03=grid%sw_asy_fac_03 &
- & ,sw_asy_fac_04=grid%sw_asy_fac_04 &
- & ,sw_asy_fac_05=grid%sw_asy_fac_05 &
- & ,sw_ssa_01=grid%sw_ssa_01 &
- & ,sw_ssa_02=grid%sw_ssa_02 &
- & ,sw_ssa_03=grid%sw_ssa_03 &
- & ,sw_ssa_04=grid%sw_ssa_04 &
- & ,sw_ssa_05=grid%sw_ssa_05 &
- & ,ozone=grid%ozone &
- & ,sw_zbbcddir=grid%sw_zbbcddir &
- & ,sw_dirdflux=grid%sw_dirdflux &
- & ,sw_difdflux=grid%sw_difdflux &
-#endif
- )
-
-BENCH_END(rad_driver_tim)
-
-!********* Surface driver
-! surface
-
-BENCH_START(surf_driver_tim)
-
-!gmm halo of wtd and riverflow for leafhydro
-#ifdef DM_PARALLEL
- IF ( ( config_flags%sf_surface_physics.eq.NOAHMPSCHEME ) .and. ( config_flags%opt_run.eq.5 ) ) THEN
- IF ( mod(grid%itimestep,grid%STEPWTD).eq.0 ) THEN
-# include "HALO_EM_HYDRO_NOAHMP.inc"
- ENDIF
- ENDIF
-#endif
-
-!-----------------------------------------------------------------
-! urban related variable are added to arguments of surface_driver
-!-----------------------------------------------------------------
- num_roof_layers = grid%num_soil_layers !urban
- num_wall_layers = grid%num_soil_layers !urban
- num_road_layers = grid%num_soil_layers !urban
- CALL nl_get_iswater(grid%id, iswater)
- CALL nl_get_isurban(grid%id, isurban)
- call nl_get_mminlu(grid%id, mminlu)
-
-#ifdef DM_PARALLEL
-# include "HALO_PWP.inc"
-#endif
-
- CALL wrf_debug ( 200 , ' call surface_driver' )
-
- if( grid%num_nests .lt. 1 )then
- HYDRO_dt = 0
- else
- HYDRO_dt = -1
- endif
-
-! Ensure WRF_Chem is compiled if bio_emiss_opt is tested, and add flag to read MEGANv2.1
-! file if bio_emiss_opt is set properly (even if chem_opt == 0).
-! Also explicitly set do_bioe to .false. if chem_opt <= 0. BJG 3/28/19
-#if( WRF_USE_CLM == 1) && (WRF_CHEM == 1)
- if( config_flags%bio_emiss_opt == MEGAN2_CLM ) then
- do_meganfile = .true.
- if(config_flags%chem_opt > 0) then !czhao +++++
- do_bioe = grid%itimestep == 1 .or. mod( grid%itimestep,grid%stepbioe ) == 0
- else
- do_bioe = .false.
- endif
- else
- do_bioe = .false.
- do_meganfile = .false.
- endif !czhao-----
-#else
- do_bioe = .false.
- do_meganfile = .false.
-#endif
-
-
-
- CALL surface_driver( &
- & HYDRO_dt=HYDRO_dt, sfcheadrt=grid%sfcheadrt, &
- & INFXSRT=grid%INFXSRT, soldrain=grid%soldrain, &
- & ACGRDFLX=grid%acgrdflx ,ACHFX=grid%achfx ,ACLHF=grid%aclhf &
- & ,ACSNOM=grid%acsnom ,ACSNOW=grid%acsnow ,AKHS=grid%akhs &
- & ,AKMS=grid%akms ,ALBBCK=grid%albbck ,ALBEDO=grid%albedo &
- & ,EMBCK=grid%embck &
- & ,BR=grid%br ,CANWAT=grid%canwat ,CHKLOWQ=chklowq &
- & ,CT=grid%ct ,DT=grid%dt ,DX=grid%dx &
- & ,DX2D=grid%dx2d ,AREA2d=grid%area2d &
- & ,DZ8W=dz8w ,DZS=grid%dzs ,FLHC=grid%flhc &
- & ,FM=grid%fm ,FHH=grid%fh &
- & ,FLQC=grid%flqc ,GLW=grid%glw ,GRDFLX=grid%grdflx &
- & ,GSW=grid%gsw ,SWDOWN=grid%swdown ,GZ1OZ0=gz1oz0 ,HFX=grid%hfx &
- & ,HT=grid%ht ,IFSNOW=config_flags%ifsnow ,ISFFLX=config_flags%isfflx &
- & ,FRACTIONAL_SEAICE=config_flags%fractional_seaice &
- & ,SEAICE_ALBEDO_OPT=config_flags%seaice_albedo_opt &
- & ,SEAICE_ALBEDO_DEFAULT=config_flags%seaice_albedo_default &
- & ,SEAICE_THICKNESS_OPT=config_flags%seaice_thickness_opt &
- & ,SEAICE_THICKNESS_DEFAULT=config_flags%seaice_thickness_default &
- & ,SEAICE_SNOWDEPTH_OPT=config_flags%seaice_snowdepth_opt &
- & ,SEAICE_SNOWDEPTH_MAX=config_flags%seaice_snowdepth_max &
- & ,SEAICE_SNOWDEPTH_MIN=config_flags%seaice_snowdepth_min &
- & ,TICE2TSK_IF2COLD=config_flags%tice2tsk_if2cold &
- & ,IFNDALBSI=grid%ifndalbsi, IFNDICEDEPTH=grid%ifndicedepth &
-#if ( WRF_CHEM == 1 )
- ,NE_AREA=grid%ne_area,E_BIO=grid%e_bio &
-#endif
- ,IFNDSNOWSI=grid%ifndsnowsi, DO_BIOE=do_bioe, DO_MEGANFILE=do_meganfile &
- & ,ISLTYP=grid%isltyp ,ITIMESTEP=grid%itimestep, JULIAN_IN=grid%julian &
- & ,IRRIGATION=grid%irrigation,SF_SURF_IRR_SCHEME=config_flags%sf_surf_irr_scheme &
- & ,IRR_DAILY_AMOUNT=config_flags%irr_daily_amount &
- & ,IRR_START_HOUR=config_flags%irr_start_hour,IRR_NUM_HOURS=config_flags%irr_num_hours &
- & ,IRR_START_JULIANDAY=config_flags%irr_start_julianday &
- & ,IRR_END_JULIANDAY=config_flags%irr_end_julianday &
- & ,IRR_FREQ=config_flags%irr_freq,IRR_PH=config_flags%irr_ph,IRR_RAND_FIELD=grid%irr_rand_field &
- & ,IVGTYP=grid%ivgtyp ,LH=grid%lh ,LOWLYR=grid%lowlyr &
- & ,MAVAIL=grid%mavail ,NUM_SOIL_LAYERS=config_flags%num_soil_layers &
- & ,P8W=grid%p_hyd_w ,PBLH=grid%pblh ,PI_PHY=pi_phy &
- & ,PSFC=grid%psfc ,PSHLTR=grid%pshltr ,PSIH=psih &
- & ,BLDT=grid%bldt ,CURR_SECS=curr_secs, ADAPT_STEP_FLAG=adapt_step_flag &
- & ,BLDTACTTIME=grid%bldtacttime &
- & ,PSIM=psim ,P_PHY=grid%p_hyd ,Q10=grid%q10 &
- & ,Q2=grid%q2 ,QFX=grid%qfx ,QSFC=grid%qsfc &
- & ,QSHLTR=grid%qshltr ,QZ0=grid%qz0 ,RAINCV=grid%raincv &
- & ,RA_LW_PHYSICS=config_flags%ra_lw_physics ,RHO=grid%rho &
- & ,RMOL=grid%rmol ,SFCEVP=grid%sfcevp ,SFCEXC=grid%sfcexc &
- & ,SFCRUNOFF=grid%sfcrunoff,ACRUNOFF=grid%ACRUNOFF &
- & ,opt_thcnd=config_flags%opt_thcnd &
- & ,SF_SFCLAY_PHYSICS=config_flags%sf_sfclay_physics &
- & ,BL_PBL_PHYSICS=config_flags%bl_pbl_physics &
- & ,SF_SURFACE_PHYSICS=config_flags%sf_surface_physics ,SH2O=grid%sh2o &
- & ,SHDMAX=grid%shdmax ,SHDMIN=grid%shdmin ,SMOIS=grid%smois &
- & ,SMSTAV=grid%smstav ,SMSTOT=grid%smstot ,SNOALB=grid%snoalb &
- & ,SNOW=grid%snow ,SNOWC=grid%snowc ,SNOWH=grid%snowh &
- & ,SMCREL=grid%smcrel &
- & ,SST=grid%sst ,SST_INPUT=grid%sst_input,SST_UPDATE=grid%sst_update &
- & ,SSTSK=grid%sstsk ,DTW=grid%dtw ,SST_SKIN=grid%sst_skin &
- & ,SCM_FORCE_SKINTEMP=grid%scm_force_skintemp &
- & ,SCM_FORCE_FLUX=grid%scm_force_flux &
- & ,STEPBL=grid%stepbl ,TH10=grid%th10 ,TH2=grid%th2 &
- & ,THZ0=grid%thz0 ,TH_PHY=th_phy ,TKE_PBL=grid%tke_pbl &
- & ,TMN=grid%tmn ,TSHLTR=grid%tshltr ,TSK=grid%tsk &
- & ,TYR=grid%tyr ,TYRA=grid%tyra ,TDLY=grid%tdly &
- & ,TLAG=grid%tlag ,LAGDAY=config_flags%lagday ,NYEAR=grid%nyear &
- & ,NDAY=grid%nday ,TMN_UPDATE=grid%tmn_update ,YR=yr &
- & ,TSLB=grid%tslb ,T_PHY=t_phy ,U10=grid%u10 &
- & ,URATX=grid%uratx ,VRATX=grid%vratx ,TRATX=grid%tratx &
- & ,UDRUNOFF=grid%udrunoff ,UST=grid%ust ,UZ0=grid%uz0 &
- & ,U_FRAME=grid%u_frame ,U_PHY=grid%u_phy ,V10=grid%v10 &
- & ,U10E=grid%u10e ,V10E=grid%v10e &
- & ,UOCE=grid%uoce ,VOCE=grid%voce &
- & ,VEGFRA=grid%vegfra ,VZ0=grid%vz0 ,V_FRAME=grid%v_frame &
- & ,V_PHY=grid%v_phy ,WARM_RAIN=grid%warm_rain &
- & ,WSPD=grid%wspd ,XICE=grid%xice ,XLAND=grid%xland &
- & ,MAX_EDOM=grid%num_ext_model_couple_dom ,CPLMASK=grid%cplmask &
- & ,Z0=grid%z0 ,Z=grid%z ,ZNT=grid%znt &
- & ,ZS=grid%zs ,ALBSI=grid%albsi , ICEDEPTH=grid%icedepth &
- & ,SNOWSI=grid%snowsi &
- & ,XICEM=grid%xicem ,ISICE=grid%landuse_isice &
- & ,USTM=grid%ustm ,CK=grid%ck ,CKA=grid%cka &
- & ,CD=grid%cd ,CDA=grid%cda &
- & ,ISFTCFLX=config_flags%isftcflx, IZ0TLND=config_flags%iz0tlnd &
- & ,SF_OCEAN_PHYSICS=config_flags%sf_ocean_physics &
- & ,OML_HML0=config_flags%oml_hml0 ,OML_GAMMA=config_flags%oml_gamma &
- & ,TML=grid%tml, T0ML=grid%t0ml, HML=grid%hml, H0ML=grid%h0ml &
- & ,HUML=grid%huml, HVML=grid%hvml, F=grid%f &
- & ,TMOML=grid%TMOML,ISWATER=iswater &
- & ,OML_RELAXATION_TIME=grid%OML_RELAXATION_TIME &
- & ,lakedepth2d=grid%lakedepth2d, savedtke12d=grid%savedtke12d &
- & ,snowdp2d=grid%snowdp2d, h2osno2d=grid%h2osno2d & !lake
- & ,snl2d=grid%snl2d, t_grnd2d=grid%t_grnd2d &
- & ,t_lake3d=grid%t_lake3d, lake_icefrac3d=grid%lake_icefrac3d & !lake
- & ,z_lake3d=grid%z_lake3d, dz_lake3d=grid%dz_lake3d &
- & ,t_soisno3d=grid%t_soisno3d, h2osoi_ice3d=grid%h2osoi_ice3d & !lake
- & ,h2osoi_liq3d=grid%h2osoi_liq3d, h2osoi_vol3d=grid%h2osoi_vol3d &
- & ,z3d=grid%z3d, dz3d=grid%dz3d & !lake
- & ,zi3d=grid%zi3d, watsat3d=grid%watsat3d &
- & ,csol3d=grid%csol3d, tkmg3d=grid%tkmg3d & !lake
- & ,tkdry3d=grid%tkdry3d, tksatu3d=grid%tksatu3d &
- & ,LakeModel=grid%sf_lake_physics, lake_min_elev=grid%lake_min_elev & !lake
-#if ( EM_CORE == 1)
- & ,LakeMask=grid%LakeMask & !lake
- & ,restart_flag=restart_flag & !flag showing if is a restart timestep
-#endif
-! CLM Varaibles
- & ,NUMC=grid%numc,NUMP=grid%nump,SABV=grid%sabv,SABG=grid%sabg, &
- & LWUP=grid%lwup,SNL=grid%snl, &
- & HISTORY_INTERVAL=config_flags%history_interval , & !ylu add hist inverval for accumulation T max/min
- & SNOWDP=grid%snowdp, WTC=grid%wtc,WTP=grid%wtp, H2OSNO=grid%h2osno, &
- & T_GRND=grid%t_grnd,T_VEG=grid%t_veg, &
- & H2OCAN=grid%h2ocan, H2OCAN_COL=grid%h2ocan_col,T2M_MAX=grid%t2m_max, &
- & T2M_MIN=grid%t2m_min,T2CLM=grid%t2clm, &
- & T_REF2M=grid%t_ref2m,H2OSOI_LIQ_S1=grid%h2osoi_liq_s1, &
- & H2OSOI_LIQ_S2=grid%h2osoi_liq_s2, &
- & H2OSOI_LIQ_S3=grid%h2osoi_liq_s3,H2OSOI_LIQ_S4=grid%h2osoi_liq_s4, &
- & H2OSOI_LIQ_S5=grid%h2osoi_liq_s5, &
- & H2OSOI_LIQ1=grid%h2osoi_liq1,H2OSOI_LIQ2=grid%h2osoi_liq2, &
- & H2OSOI_LIQ3=grid%h2osoi_liq3,H2OSOI_LIQ4=grid%h2osoi_liq4, &
- & H2OSOI_LIQ5=grid%h2osoi_liq5,H2OSOI_LIQ6=grid%h2osoi_liq6, &
- & H2OSOI_LIQ7=grid%h2osoi_liq7,H2OSOI_LIQ8=grid%h2osoi_liq8, &
- & H2OSOI_LIQ9=grid%h2osoi_liq9, H2OSOI_LIQ10=grid%h2osoi_liq10, &
- & H2OSOI_ICE_S1=grid%h2osoi_ice_s1,H2OSOI_ICE_S2=grid%h2osoi_ice_s2, &
- & H2OSOI_ICE_S3=grid%h2osoi_ice_s3, H2OSOI_ICE_S4=grid%h2osoi_ice_s4, &
- & H2OSOI_ICE_S5=grid%h2osoi_ice_s5, &
- & H2OSOI_ICE1=grid%h2osoi_ice1, H2OSOI_ICE2=grid%h2osoi_ice2, &
- & H2OSOI_ICE3=grid%h2osoi_ice3,H2OSOI_ICE4=grid%h2osoi_ice4, &
- & H2OSOI_ICE5=grid%h2osoi_ice5, H2OSOI_ICE6=grid%h2osoi_ice6, &
- & H2OSOI_ICE7=grid%h2osoi_ice7,H2OSOI_ICE8=grid%h2osoi_ice8, &
- & H2OSOI_ICE9=grid%h2osoi_ice9,H2OSOI_ICE10=grid%h2osoi_ice10, &
- & T_SOISNO_S1=grid%t_soisno_s1,T_SOISNO_S2=grid%t_soisno_s2, &
- & T_SOISNO_S3=grid%t_soisno_s3,T_SOISNO_S4=grid%t_soisno_s4, &
- & T_SOISNO_S5=grid%t_soisno_s5,T_SOISNO1=grid%t_soisno1, &
- & T_SOISNO2=grid%t_soisno2,T_SOISNO3=grid%t_soisno3, &
- & T_SOISNO4=grid%t_soisno4,T_SOISNO5=grid%t_soisno5, &
- & T_SOISNO6=grid%t_soisno6,T_SOISNO7=grid%t_soisno7, &
- & T_SOISNO8=grid%t_soisno8,T_SOISNO9=grid%t_soisno9, &
- & T_SOISNO10=grid%t_soisno10,DZSNOW1=grid%dzsnow1,DZSNOW2=grid%dzsnow2,&
- & DZSNOW3=grid%dzsnow3,DZSNOW4=grid%dzsnow4, DZSNOW5=grid%dzsnow5, &
- & SNOWRDS1=grid%snowrds1,SNOWRDS2=grid%snowrds2, &
- & SNOWRDS3=grid%snowrds3 ,SNOWRDS4=grid%snowrds4, &
- & SNOWRDS5=grid%snowrds5, &
- & T_LAKE1=grid%t_lake1,T_LAKE2=grid%t_lake2,T_LAKE3=grid%t_lake3, &
- & T_LAKE4=grid%t_lake4, &
- & T_LAKE5=grid%t_lake5,T_LAKE6=grid%t_lake6, T_LAKE7=grid%t_lake7, &
- & T_LAKE8=grid%t_lake8, T_LAKE9=grid%t_lake9,T_LAKE10=grid%t_lake10, &
- & H2OSOI_VOL1=grid%h2osoi_vol1,H2OSOI_VOL2=grid%h2osoi_vol2, &
- & H2OSOI_VOL3=grid%h2osoi_vol3,H2OSOI_VOL4=grid%h2osoi_vol4, &
- & H2OSOI_VOL5=grid%h2osoi_vol5, &
- & H2OSOI_VOL6=grid%h2osoi_vol6,H2OSOI_VOL7=grid%h2osoi_vol7, &
- & H2OSOI_VOL8=grid%h2osoi_vol8, &
- & H2OSOI_VOL9=grid%h2osoi_vol9,H2OSOI_VOL10=grid%h2osoi_vol10, &
- & MAXPATCH=config_flags%maxpatch, &
- & INEST=grid%id,ALBEDOsubgrid=grid%ALBEDOsubgrid, &
- & LHsubgrid=grid%LHsubgrid, &
- & HFXsubgrid=grid%HFXsubgrid,LWUPsubgrid=grid%LWUPsubgrid, &
- & Q2subgrid=grid%Q2subgrid,SABVsubgrid=grid%SABVsubgrid, &
- & SABGsubgrid=grid%SABGsubgrid,NRAsubgrid=grid%NRAsubgrid, &
- & SWUPsubgrid=grid%SWUPsubgrid,LHsoi=grid%LHsoi, &
- & LHveg=grid%LHveg, LHtran=grid%LHtran &
- ,t_veg24=grid%t_veg24, t_veg240=grid%t_veg240, & !voce accum variables
- fsun24=grid%fsun24, fsun240=grid%fsun240, & !voce accum variables
- fsd24=grid%fsd24, fsd240=grid%fsd240, & !voce accum variables
- fsi24=grid%fsi24, fsi240=grid%fsi240, & !voce accum variables
- laip=grid%laip, & !voce accum variables
- pct_pft_input=grid%pct_pft_input,num_pft_input=grid%num_pft_clm, &
- input_pft_flag=config_flags%input_pft &
-! end of CLM variables
- & ,SLOPE_RAD=config_flags%slope_rad,TOPO_SHADING=config_flags%topo_shading & ! solar
- & ,SHADOWMASK=grid%shadowmask,DIFFUSE_FRAC=grid%diffuse_frac & ! solar
- & ,SLOPE=grid%slope, SLP_AZI=grid%slp_azi, SWNORM=grid%swnorm & ! solar
- & ,DECLIN=grid%declin ,SOLCON=grid%solcon ,COSZEN=grid%coszen ,HRANG=grid%hrang &
- & ,xlat_urb2d=grid%XLAT & !I urban
- & ,NUM_ROOF_LAYERS=num_roof_layers & !I urban
- & ,NUM_WALL_LAYERS=num_wall_layers & !I urban
- & ,NUM_ROAD_LAYERS=num_road_layers &
- & ,DZR=grid%dzr ,DZB=grid%dzb ,DZG=grid%dzg & !I urban
- & ,TR_URB2D=grid%tr_urb2d ,TB_URB2D=grid%tb_urb2d &
- & ,TG_URB2D=grid%tg_urb2d & !H urban
- & ,TC_URB2D=grid%tc_urb2d ,QC_URB2D=grid%qc_urb2d & !H urban
- & ,UC_URB2D=grid%uc_urb2d & !H urban
- & ,XXXR_URB2D=grid%xxxr_urb2d &
- & ,XXXB_URB2D=grid%xxxb_urb2d & !H urban
- & ,XXXG_URB2D=grid%xxxg_urb2d &
- & ,XXXC_URB2D=grid%xxxc_urb2d & !H urban
- & ,CMCR_URB2D=grid%cmcr_urb2d,TGR_URB2D=grid%tgr_urb2d & !H urban
- & ,TGRL_URB3D=grid%tgrl_urb3d,SMR_URB3D=grid%smr_urb3d & !H urban
- & ,JULIAN=grid%julday, JULYR=grid%julyr & !I urban
- & ,DRELR_URB2D=grid%drelr_urb2d,DRELB_URB2D=grid%drelb_urb2d & !H urban
- & ,DRELG_URB2D=grid%drelg_urb2d & !H urban
- & ,FLXHUMR_URB2D=grid%flxhumr_urb2d & !H urban
- & ,FLXHUMB_URB2D=grid%flxhumb_urb2d & !H urban
- & ,FLXHUMG_URB2D=grid%flxhumg_urb2d & !H urban
- & ,TRL_URB3D=grid%trl_urb3d ,TBL_URB3D=grid%tbl_urb3d & !H urban
- & ,TGL_URB3D=grid%tgl_urb3d & !H urban
- & ,SH_URB2D=grid%sh_urb2d ,LH_URB2D=grid%lh_urb2d &
- & ,G_URB2D=grid%g_urb2d & !H urban
- & ,RN_URB2D=grid%rn_urb2d , TS_URB2D=grid%ts_urb2d & !H urban
- & ,FRC_URB2D=grid%frc_urb2d & !H urban
- & ,UTYPE_URB2D=grid%utype_urb2d & !H urban
- & ,SWDDIR=grid%swddir,SWDDIF=grid%swddif & !multi-layer urban _gl
- ! Optional urban for BEP scheme
- & ,SF_URBAN_PHYSICS=config_flags%sf_urban_physics &
- & ,num_urban_ndm = config_flags%num_urban_ndm & !multi-layer urban
- & ,urban_map_zrd = config_flags%urban_map_zrd & !multi-layer urban
- & ,urban_map_zwd = config_flags%urban_map_zwd & !multi-layer urban
- & ,urban_map_gd = config_flags%urban_map_gd & !multi-layer urban
- & ,urban_map_zd = config_flags%urban_map_zd & !multi-layer urban
- & ,urban_map_zdf = config_flags%urban_map_zdf & !multi-layer urban
- & ,urban_map_bd = config_flags%urban_map_bd & !multi-layer urban
- & ,urban_map_wd = config_flags%urban_map_wd & !multi-layer urban
- & ,urban_map_gbd = config_flags%urban_map_gbd & !multi-layer urban
- & ,urban_map_fbd = config_flags%urban_map_fbd & !multi-layer urban
- & ,urban_map_zgrd = config_flags%urban_map_zgrd & !multi-layer urban
- & ,NUM_URBAN_HI=config_flags%num_urban_hi & !multi-layer urban
- & ,TSK_RURAL=grid%tsk_rural & !multi-layer urban
- & ,TRB_URB4D=grid%trb_urb4d,TW1_URB4D=grid%tw1_urb4d & !multi-layer urban
- & ,TW2_URB4D=grid%tw2_urb4d,TGB_URB4D=grid%tgb_urb4d & !multi-layer urban
- & ,TLEV_URB3D=grid%tlev_urb3d & !multi-layer urban
- & ,QLEV_URB3D=grid%qlev_urb3d & !multi-layer urban
- & ,TW1LEV_URB3D=grid%tw1lev_urb3d & !multi-layer urban
- & ,TW2LEV_URB3D=grid%tw2lev_urb3d & !multi-layer urban
- & ,TGLEV_URB3D=grid%tglev_urb3d & !multi-layer urban
- & ,TFLEV_URB3D=grid%tflev_urb3d & !multi-layer urban
- & ,SF_AC_URB3D=grid%sf_ac_urb3d & !multi-layer urban
- & ,LF_AC_URB3D=grid%lf_ac_urb3d & !multi-layer urban
- & ,CM_AC_URB3D=grid%cm_ac_urb3d & !multi-layer urban
- & ,SFVENT_URB3D=grid%sfvent_urb3d & !multi-layer urban
- & ,LFVENT_URB3D=grid%lfvent_urb3d & !multi-layer urban
- & ,SFWIN1_URB3D=grid%sfwin1_urb3d & !multi-layer urban
- & ,SFWIN2_URB3D=grid%sfwin2_urb3d & !multi-layer urban
- & ,SFW1_URB3D=grid%sfw1_urb3d,SFW2_URB3D=grid%sfw2_urb3d & !multi-layer urban
- & ,SFR_URB3D=grid%sfr_urb3d,SFG_URB3D=grid%sfg_urb3d & !multi-layer urban
- & ,EP_PV_URB3D=grid%ep_pv_urb3d & !GRZ
- & ,T_PV_URB3D=grid%t_pv_urb3d & !GRZ
- & ,TRV_URB4D=grid%trv_urb4d & !GRZ
- & ,QR_URB4D=grid%qr_urb4d & !GRZ
- & ,QGR_URB3D=grid%qgr_urb3d & !GRZ
- & ,TGR_URB3D=grid%tgr_urb3d & !GRZ
- & ,DRAIN_URB4D=grid%drain_urb4d & !GRZ
- & ,DRAINGR_URB3D=grid%draingr_urb3d & !GRZ
- & ,SFRV_URB3D=grid%sfrv_urb3d & !GRZ
- & ,LFRV_URB3D=grid%lfrv_urb3d & !GRZ
- & ,DGR_URB3D=grid%dgr_urb3d & !GRZ
- & ,DG_URB3D=grid%dg_urb3d & !GRZ
- & ,LFR_URB3D=grid%lfr_urb3d & !GRZ
- & ,LFG_URB3D=grid%lfg_urb3d & !GRZ
- & ,LP_URB2D=grid%lp_urb2d,HI_URB2D=grid%hi_urb2d & !multi-layer urban
- & ,LB_URB2D=grid%lb_urb2d,HGT_URB2D=grid%hgt_urb2d & !multi-layer urban
- & ,MH_URB2D=grid%mh_urb2d,STDH_URB2D=grid%stdh_urb2d & !SLUCM
- & ,LF_URB2D=grid%lf_urb2d &
- & ,GMT=grid%gmt,XLAT=grid%xlat,XLONG=grid%xlong,JULDAY=grid%julday &
- & ,A_U_BEP=grid%a_u_bep,A_V_BEP=grid%a_v_bep,A_T_BEP=grid%a_t_bep &
- & ,A_Q_BEP=grid%a_q_bep &
- & ,B_U_BEP=grid%b_u_bep,B_V_BEP=grid%b_v_bep,B_T_BEP=grid%b_t_bep &
- & ,B_Q_BEP=grid%b_q_bep &
- & ,SF_BEP=grid%sf_bep,VL_BEP=grid%vl_bep &
- & ,A_E_BEP=grid%a_e_bep,B_E_BEP=grid%b_e_bep,DLG_BEP=grid%dlg_bep &
- & ,DL_U_BEP=grid%dl_u_bep &
- & ,CMR_SFCDIF=grid%cmr_sfcdif, CHR_SFCDIF=grid%chr_sfcdif & !I/O urban
- & ,CMC_SFCDIF=grid%cmc_sfcdif, CHC_SFCDIF=grid%chc_sfcdif & !I/O urban
- & ,CMGR_SFCDIF=grid%cmgr_sfcdif, CHGR_SFCDIF=grid%chgr_sfcdif & !I/O urban
- ! P-X LSM Variables
- & ,LANDUSEF=grid%landusef, SOILCTOP=grid%soilctop & ! P-X LSM
- & ,SOILCBOT=grid%soilcbot & ! P-X LSM
- & ,RA=grid%ra, RS=grid%rs, LAI=grid%lai, IMPERV=grid%imperv & ! P-X LSM
- & ,CANFRA=grid%canfra, NLCAT=grid%num_land_cat & ! P-X LSM
- & ,NSCAT=grid%num_soil_cat & ! P-X LSM
- & ,VEGF_PX=grid%vegf_px, SNOWNCV=grid%snowncv & ! P-X LSM
- & ,ANAL_INTERVAL=config_flags%auxinput9_interval_s+config_flags%auxinput9_interval_m*60 & ! P-X LSM
- & ,PXLSM_SMOIS_INIT=config_flags%pxlsm_smois_init & ! P-X LSM
- & ,PXLSM_SOIL_NUDGE=config_flags%pxlsm_soil_nudge & ! P-X LSM
- ! SSiB LSM variables (fds 06/2010)
- & ,alswvisdir=grid%alswvisdir, alswvisdif=grid%alswvisdif & !ssib
- & ,alswnirdir=grid%alswnirdir, alswnirdif=grid%alswnirdif & !ssib
- & ,swvisdir=grid%swvisdir, swvisdif=grid%swvisdif & !ssib
- & ,swnirdir=grid%swnirdir, swnirdif=grid%swnirdif & !ssib
- & ,ssib_br=grid%ssib_br, ssib_fm=grid%ssib_fm & !ssib
- & ,ssib_fh=grid%ssib_fh, ssib_cm=grid%ssib_cm & !ssib
- & ,ssibxdd=grid%ssibxdd, ssib_lhf=grid%ssib_lhf & !ssib
- & ,ssib_shf=grid%ssib_shf, ssib_ghf=grid%ssib_ghf & !ssib
- & ,ssib_egs=grid%ssib_egs, ssib_eci=grid%ssib_eci & !ssib
- & ,ssib_ect=grid%ssib_ect, ssib_egi=grid%ssib_egi & !ssib
- & ,ssib_egt=grid%ssib_egt, ssib_sdn=grid%ssib_sdn & !ssib
- & ,ssib_sup=grid%ssib_sup, ssib_ldn=grid%ssib_ldn & !ssib
- & ,ssib_lup=grid%ssib_lup, ssib_wat=grid%ssib_wat & !ssib
- & ,ssib_shc=grid%ssib_shc, ssib_shg=grid%ssib_shg & !ssib
- & ,ssib_lai=grid%ssib_lai, ssib_vcf=grid%ssib_vcf & !ssib
- & ,ssib_z00=grid%ssib_z00, ssib_veg=grid%ssib_veg & !ssib
- & ,cldfra=grid%cldfra & !ssib
- & ,ISNOW=grid%isnow, SWE=grid%swe, SNOWDEN=grid%snowden & !ssib snow
- & ,SNOWDEPTH=grid%snowdepth, TKAIR=grid%tkair & !ssib snow
- & ,DZO1=grid%dzo1, WO1=grid%wo1, TSSN1=grid%tssn1, TSSNO1=grid%tssno1 & !ssib snow
- & ,BWO1=grid%bwo1, BTO1=grid%bto1, CTO1=grid%cto1, FIO1=grid%fio1 & !ssib snow
- & ,FLO1=grid%flo1, BIO1=grid%bio1, BLO1=grid%blo1, HO1=grid%ho1 & !ssib snow
- & ,DZO2=grid%dzo2, WO2=grid%wo2, TSSN2=grid%tssn2, TSSNO2=grid%tssno2 & !ssib snow
- & ,BWO2=grid%bwo2, BTO2=grid%bto2, CTO2=grid%cto2, FIO2=grid%fio2 & !ssib snow
- & ,FLO2=grid%flo2, BIO2=grid%bio2, BLO2=grid%blo2, HO2=grid%ho2 & !ssib snow
- & ,DZO3=grid%dzo3, WO3=grid%wo3, TSSN3=grid%tssn3, TSSNO3=grid%tssno3 & !ssib snow
- & ,BWO3=grid%bwo3, BTO3=grid%bto3, CTO3=grid%cto3, FIO3=grid%fio3 & !ssib snow
- & ,FLO3=grid%flo3, BIO3=grid%bio3, BLO3=grid%blo3, HO3=grid%ho3 & !ssib snow
- & ,DZO4=grid%dzo4, WO4=grid%wo4, TSSN4=grid%tssn4, TSSNO4=grid%tssno4 & !ssib snow
- & ,BWO4=grid%bwo4, BTO4=grid%bto4, CTO4=grid%cto4, FIO4=grid%fio4 & !ssib snow
- & ,FLO4=grid%flo4, BIO4=grid%bio4, BLO4=grid%blo4, HO4=grid%ho4 & !ssib snow
- & ,RA_SW_PHYSICS=config_flags%ra_sw_physics & !ssib
-!------------------------------------------------------------------------------
- ! Optional PX LSM nudging
- & ,t2_ndg_old=grid%t2_ndg_old &
- & ,q2_ndg_old=grid%q2_ndg_old &
- & ,t2_ndg_new=grid%t2_ndg_new &
- & ,q2_ndg_new=grid%q2_ndg_new &
- & ,sn_ndg_old=grid%sn_ndg_old &
- & ,sn_ndg_new=grid%sn_ndg_new &
- & ,pxlsm_modis_veg=config_flags%pxlsm_modis_veg &
- & ,LAI_PX=grid%lai_px &
- & ,WWLT_PX=grid%wwlt_px, WFC_PX=grid%wfc_px &
- & ,WSAT_PX=grid%wsat_px, CLAY_PX=grid%clay_px &
- & ,CSAND_PX=grid%csand_px, FMSAND_PX=grid%fmsand_px &
-! for Noah-MP LSM
- & ,idveg=config_flags%dveg, iopt_crs=config_flags%opt_crs &
- & ,iopt_btr=config_flags%opt_btr, iopt_run=config_flags%opt_run &
- & ,iopt_sfc=config_flags%opt_sfc, iopt_frz=config_flags%opt_frz &
- & ,iopt_inf=config_flags%opt_inf, iopt_rad=config_flags%opt_rad &
- & ,iopt_alb=config_flags%opt_alb, iopt_snf=config_flags%opt_snf &
- & ,iopt_tbot=config_flags%opt_tbot, iopt_stc=config_flags%opt_stc &
- & ,iopt_gla=config_flags%opt_gla, iopt_rsf=config_flags%opt_rsf &
- & ,iopt_soil=config_flags%opt_soil, iopt_pedo=config_flags%opt_pedo &
- & ,iopt_crop=config_flags%opt_crop, iopt_irr=config_flags%opt_irr &
- & ,iopt_irrm=config_flags%opt_irrm &
- & , isnowxy=grid%isnowxy , tvxy=grid%tvxy , tgxy=grid%tgxy &
- & ,canicexy=grid%canicexy ,canliqxy=grid%canliqxy, eahxy=grid%eahxy &
- & , tahxy=grid%tahxy , cmxy=grid%cmxy , chxy=grid%chxy &
- & , fwetxy=grid%fwetxy ,sneqvoxy=grid%sneqvoxy,alboldxy=grid%alboldxy &
- & , qsnowxy=grid%qsnowxy ,qrainxy=grid%qrainxy ,wslakexy=grid%wslakexy &
- & , zwtxy=grid%zwtxy &
- & , waxy=grid%waxy , wtxy=grid%wtxy , tsnoxy=grid%tsnoxy &
- & , zsnsoxy=grid%zsnsoxy , snicexy=grid%snicexy , snliqxy=grid%snliqxy &
- & ,lfmassxy=grid%lfmassxy ,rtmassxy=grid%rtmassxy,stmassxy=grid%stmassxy &
- & , woodxy=grid%woodxy ,stblcpxy=grid%stblcpxy,fastcpxy=grid%fastcpxy &
- & , grainxy=grid%grainxy , gddxy=grid%gddxy , pgsxy=grid%pgsxy &
- & , cropcat=grid%cropcat &
- & ,planting=grid%planting , harvest=grid%harvest ,season_gdd=grid%season_gdd &
- & , soilcomp=grid%soilcomp &
- & , soilcl1=grid%soilcl1 , soilcl2=grid%soilcl2 &
- & , soilcl3=grid%soilcl3 , soilcl4=grid%soilcl4 &
- & , xsaixy=grid%xsaixy , taussxy=grid%taussxy &
- & , t2mvxy=grid%t2mvxy , t2mbxy=grid%t2mbxy &
- & , q2mvxy=grid%q2mvxy , q2mbxy=grid%q2mbxy &
- & , tradxy=grid%tradxy , neexy=grid%neexy , gppxy=grid%gppxy &
- & , nppxy=grid%nppxy , fvegxy=grid%fvegxy , runsfxy=grid%runsfxy &
- & , runsbxy=grid%runsbxy , ecanxy=grid%ecanxy , edirxy=grid%edirxy &
- & , etranxy=grid%etranxy , fsaxy=grid%fsaxy , firaxy=grid%firaxy &
- & , aparxy=grid%aparxy , psnxy=grid%psnxy , savxy=grid%savxy &
- & , sagxy=grid%sagxy , rssunxy=grid%rssunxy , rsshaxy=grid%rsshaxy &
- & , bgapxy=grid%bgapxy , wgapxy=grid%wgapxy , tgvxy=grid%tgvxy &
- & , tgbxy=grid%tgbxy , chvxy=grid%chvxy , chbxy=grid%chbxy &
- & , shgxy=grid%shgxy , shcxy=grid%shcxy , shbxy=grid%shbxy &
- & , evgxy=grid%evgxy , evbxy=grid%evbxy , ghvxy=grid%ghvxy &
- & , ghbxy=grid%ghbxy , irgxy=grid%irgxy , ircxy=grid%ircxy &
- & , irbxy=grid%irbxy , trxy=grid%trxy , evcxy=grid%evcxy &
- & ,chleafxy=grid%chleafxy , chucxy=grid%chucxy &
- & , chv2xy=grid%chv2xy , chb2xy=grid%chb2xy , chstarxy=grid%chstarxy &
- !Noah-MP irrigation
- & , IRFRACT=grid%IRFRACT , SIFRACT=grid%SIFRACT ,MIFRACT=grid%MIFRACT &
- & , FIFRACT=grid%FIFRACT , IRNUMSI=grid%IRNUMSI ,IRNUMMI=grid%IRNUMMI &
- & , IRNUMFI=grid%IRNUMFI , IRWATSI=grid%IRWATSI ,IRWATMI=grid%IRWATMI &
- & , IRWATFI=grid%IRWATFI , IRELOSS=grid%IRELOSS ,IRSIVOL=grid%IRSIVOL &
- & , IRMIVOL=grid%IRMIVOL , IRFIVOL=grid%IRFIVOL ,IRRSPLH=grid%IRRSPLH &
- !Optional hydro variables in NOAHMP
- & ,smcwtdxy=grid%smcwtdxy ,rechxy=grid%rechxy ,deeprechxy=grid%deeprechxy &
- & ,fdepthxy=grid%fdepthxy, areaxy=grid%areaxy, rivercondxy=grid%rivercondxy &
- & ,riverbedxy=grid%riverbedxy, eqzwt=grid%eqzwt, pexpxy=grid%pexpxy &
- & ,qrfxy=grid%qrfxy, qspringxy=grid%qspringxy, qslatxy=grid%qslatxy, qrfsxy=grid%qrfsxy &
- & ,qspringsxy=grid%qspringsxy, smoiseq=grid%smoiseq, wtddt=config_flags%wtddt, stepwtd=grid%stepwtd &
- & ,gecros_state=grid%gecros_state & ! Optional gecros crop
- ! Noah UA changes
- & ,ua_phys=config_flags%ua_phys,flx4=grid%flx4,fvb=grid%fvb &
- & ,fbur=grid%fbur,fgsn=grid%fgsn &
- ! Indexes
- & ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &
- & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
- & ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe &
- & , I_START=grid%i_start,I_END=min(grid%i_end, ide-1) &
- & , J_START=grid%j_start,J_END=min(grid%j_end, jde-1) &
- & , KTS=k_start, KTE=min(k_end,kde-1) &
- & , NUM_TILES=grid%num_tiles &
- ! Variables required by TEMF PBL - WA 1/7/09
- ,te_temf=grid%te_temf,hd_temf=grid%hd_temf &
- ,fCor=grid%f,exch_temf=exch_temf,wm_temf=grid%wm_temf &
- ! Variables required by IDEAL SCM sfc scheme - WA 1/6/10
- ,hfx_force=grid%hfx_force,lh_force=grid%lh_force &
- ,tsk_force=grid%tsk_force &
- ,hfx_force_tend=grid%hfx_force_tend &
- ,lh_force_tend=grid%lh_force_tend &
- ,tsk_force_tend=grid%tsk_force_tend &
- ! Optional
- & ,QV_CURR=moist(ims,kms,jms,P_QV), F_QV=F_QV &
- & ,QC_CURR=moist(ims,kms,jms,P_QC), F_QC=F_QC &
- & ,QR_CURR=moist(ims,kms,jms,P_QR), F_QR=F_QR &
- & ,QI_CURR=moist(ims,kms,jms,P_QI), F_QI=F_QI &
- & ,QS_CURR=moist(ims,kms,jms,P_QS), F_QS=F_QS &
- & ,QG_CURR=moist(ims,kms,jms,P_QG), F_QG=F_QG &
- & ,CAPG=grid%capg, EMISS=grid%emiss, HOL=hol,MOL=grid%mol &
- & ,T2OBS=grid%t2obs, Q2OBS=grid%q2obs &
- & ,RAINBL=grid%rainbl,SR=grid%sr,RAINSHV=grid%rainshv &
- & ,GRAUPELNCV=grid%graupelncv, HAILNCV=grid%hailncv &
- & ,RAINNCV=grid%rainncv,REGIME=grid%regime,T2=grid%t2,THC=grid%thc &
- & ,QSG=grid%qsg,QVG=grid%qvg,QCG=grid%qcg,SOILT1=grid%soilt1,TSNAV=grid%tsnav & ! ruc lsm
- & ,SMFR3D=grid%smfr3d,KEEPFR3DFLAG=grid%keepfr3dflag,DEW=grid%dew & ! ruc lsm
- & ,POTEVP=grid%POTEVP, SNOPCX=grid%SNOPCX, SOILTB=grid%SOILTB & ! ruc lsm
- & ,rhosnf=grid%rhosnf ,precipfr=grid%precipfr & ! RUC LSM
- & ,snowfallac=grid%snowfallac & ! RUC LSM
- & ,MOSAIC_LU=config_flags%mosaic_lu & ! RUC LSM
- & ,MOSAIC_SOIL=config_flags%mosaic_soil & ! RUC LSM
- & ,ISURBAN=isurban, MMINLU=TRIM(mminlu) &
- & ,SNOTIME = grid%SNOTIME &
- & ,RDLAI2D=config_flags%rdlai2d &
- & ,usemonalb=config_flags%usemonalb &
- & ,NOAHRES=grid%noahres &
- & ,TSK_SAVE=grid%tsk_save &
- & ,ch=grid%ch &
- & ,fgdp=grid%fgdp,dfgdp=grid%dfgdp,vdfg=grid%vdfg & !Katata - fogdes
- & ,grav_settling=config_flags%grav_settling & !Katata - fogdes
- & ,OM_TMP=grid%om_tmp, OM_S=grid%om_s, OM_U=grid%om_u, OM_V=grid%om_v & !cyl:3DPWP
- & ,OM_DEPTH=grid%om_depth, OM_ML=grid%OM_ML, OM_LON=grid%om_lon & !cyl:3DPWP
- & ,OM_LAT=grid%om_lat & !cy:3DPWP
- & , okms = 1, okme=config_flags%ocean_levels & ! cyl:3DPWP
- & ,rdx=grid%rdx, rdy=grid%rdy,msfu=grid%msfu,msfv=grid%msfv,msft=grid%msft &!cyl: 3DPWP
- & ,XTIME=grid%xtime,OM_TINI=grid%om_tini,OM_SINI=grid%om_sini,id=grid%id,omdt=config_flags%omdt &!cyl: 3DPWP
- & ,sf_surface_mosaic=config_flags%sf_surface_mosaic, mosaic_cat=config_flags%mosaic_cat &
- & ,mosaic_cat_index=grid%mosaic_cat_index & !danli mosaic
- & ,landusef2=grid%landusef2,TSK_mosaic=grid%TSK_mosaic,QSFC_mosaic=grid%QSFC_mosaic &
- & ,TSLB_mosaic=grid%TSLB_mosaic,SMOIS_mosaic=grid%SMOIS_mosaic,SH2O_mosaic=grid%SH2O_mosaic & !danli mosaic
- & ,CANWAT_mosaic=grid%CANWAT_mosaic,SNOW_mosaic=grid%SNOW_mosaic &
- & ,SNOWH_mosaic=grid%SNOWH_mosaic,SNOWC_mosaic=grid%SNOWC_mosaic & !danli mosaic
- & ,ALBEDO_mosaic=grid%ALBEDO_mosaic,ALBBCK_mosaic=grid%ALBBCK_mosaic &
- & ,EMISS_mosaic=grid%EMISS_mosaic, EMBCK_mosaic=grid%EMBCK_mosaic &
- & ,ZNT_mosaic=grid%ZNT_mosaic, Z0_mosaic=grid%Z0_mosaic & !danli mosaic
- & ,HFX_mosaic=grid%HFX_mosaic,QFX_mosaic=grid%QFX_mosaic, LH_mosaic=grid%LH_mosaic &
- & ,GRDFLX_mosaic=grid%GRDFLX_mosaic,SNOTIME_mosaic=grid%SNOTIME_mosaic & !danli mosaic
- & ,RS_mosaic=grid%RS_mosaic,LAI_mosaic=grid%LAI_mosaic &
- & ,TR_URB2D_mosaic=grid%TR_URB2D_mosaic,TB_URB2D_mosaic=grid%TB_URB2D_mosaic & !danli mosaic
- & ,TG_URB2D_mosaic=grid%TG_URB2D_mosaic,TC_URB2D_mosaic=grid%TC_URB2D_mosaic & !danli mosaic
- & ,QC_URB2D_mosaic=grid%QC_URB2D_mosaic,UC_URB2D_mosaic=grid%UC_URB2D_mosaic & !danli mosaic
- & ,TRL_URB3D_mosaic=grid%TRL_URB3D_mosaic,TBL_URB3D_mosaic=grid%TBL_URB3D_mosaic & !danli mosaic
- & ,TGL_URB3D_mosaic=grid%TGL_URB3D_mosaic & !danli mosaic
- & ,SH_URB2D_mosaic=grid%SH_URB2D_mosaic,LH_URB2D_mosaic=grid%LH_URB2D_mosaic & !danli mosaic
- & ,G_URB2D_mosaic=grid%G_URB2D_mosaic,RN_URB2D_mosaic=grid%RN_URB2D_mosaic & !danli mosaic
- & ,TS_URB2D_mosaic=grid%TS_URB2D_mosaic & !danli mosaic
- & ,TS_RUL2D_mosaic=grid%TS_RUL2D_mosaic & !danli mosaic
- & ,ZOL=grid%ZOL &
- & ,SDA_HFX=grid%SDA_HFX, SDA_QFX=grid%SDA_QFX,HFX_BOTH=grid%HFX_BOTH & !fasdas
- & ,QFX_BOTH=grid%QFX_BOTH,QNORM=grid%QNORM,fasdas=config_flags%fasdas & !fasdas
- & ,XLAIDYN=grid%XLAIDYN &
- & ,spp_lsm=config_flags%spp_lsm,pattern_spp_lsm=grid%pattern_spp_lsm & !SPP
- & ,field_sf=grid%field_sf & !SPP
- & ,spp_pbl=config_flags%spp_pbl,pattern_spp_pbl=grid%pattern_spp_pbl & !SPP
- & )
-
-#ifdef WRF_HYDRO
- if(HYDRO_dt .gt. 1 ) call wrf_drv_HYDRO(HYDRO_dt, grid, &
- & grid%i_start(1),min(grid%i_end(1), ide-1), &
- & grid%j_start(1),min(grid%j_end(1), jde-1) )
-#endif
-
-BENCH_END(surf_driver_tim)
-
-!*********
-! pbl
-#if ( WRFPLUS == 1 )
-#ifdef DM_PARALLEL
- IF ( config_flags%bl_pbl_physics .EQ. 98 ) THEN
-# include "HALO_EM_PHYS_A_BL_SURF.inc"
- ENDIF
-#endif
-#endif
-
- CALL wrf_debug ( 200 , ' call pbl_driver' )
-BENCH_START(pbl_driver_tim)
- CALL pbl_driver( &
- & AKHS=grid%akhs ,AKMS=grid%akms &
- & ,BL_PBL_PHYSICS=config_flags%bl_pbl_physics &
- & ,WINDFARM_OPT=config_flags%windfarm_opt,power=grid%power &
- & ,BLDT=grid%bldt, CURR_SECS=curr_secs, ADAPT_STEP_FLAG=adapt_step_flag &
- & ,BLDTACTTIME=grid%bldtacttime &
- & ,BR=grid%br ,CHKLOWQ=chklowq ,CT=grid%ct &
- & ,DT=grid%dt ,DX=grid%dx ,DY=grid%dy &
- & ,DX2D=grid%dx2d ,AREA2D=grid%area2d &
- & ,DZ8W=dz8w ,HPBL_HOLD=hpbl_hold &
- & ,EXCH_H=grid%exch_h ,EXCH_M=grid%exch_m &
- & ,FM=grid%fm ,FHH=grid%fh &
- & ,F=grid%f ,GRDFLX=grid%grdflx &
- & ,GZ1OZ0=gz1oz0 ,HFX=grid%hfx ,HT=grid%ht &
- & ,ID=grid%id ,ITIMESTEP=grid%itimestep ,KPBL=grid%kpbl &
- & ,LH=grid%lh ,LOWLYR=grid%lowlyr ,P8W=grid%p_hyd_w &
- & ,PBLH=grid%pblh ,PI_PHY=pi_phy ,PSIH=psih &
- & ,PSIM=psim ,P_PHY=grid%p_hyd ,QFX=grid%qfx &
- & ,QSFC=grid%qsfc ,QZ0=grid%qz0 ,MIXHT=mixht &
- & ,RA_LW_PHYSICS=config_flags%ra_lw_physics &
- & ,RHO=grid%rho ,RQCBLTEN=grid%rqcblten ,RQIBLTEN=grid%rqiblten &
- & ,RQVBLTEN=grid%rqvblten ,RTHBLTEN=grid%rthblten ,RUBLTEN=grid%rublten &
- & ,RVBLTEN=grid%rvblten ,SNOW=grid%snow ,STEPBL=grid%stepbl &
- & ,THZ0=grid%thz0 ,TH_PHY=th_phy &
- & ,TSK=grid%tsk ,T_PHY=grid%t_phy ,UST=grid%ust &
- & ,U10=grid%u10 ,UZ0=grid%uz0 ,U_FRAME=grid%u_frame ,U_PHY=grid%u_phy &
- & ,V10=grid%v10 ,VZ0=grid%vz0 ,V_FRAME=grid%v_frame ,V_PHY=grid%v_phy &
- & ,W=grid%w_2 ,UOCE=grid%uoce ,VOCE=grid%voce &
- ,T2=grid%t2 &
- & ,WARM_RAIN=grid%warm_rain ,WSPD=grid%wspd &
- & ,XICE=grid%xice ,XLAND=grid%xland ,Z=grid%z &
- & ,ZNT=grid%znt &
- & ,ysu_topdown_pblmix=config_flags%ysu_topdown_pblmix &
- & ,shinhong_tke_diag=config_flags%shinhong_tke_diag &
-! paj: topo_wind
- & ,CTOPO=grid%ctopo,CTOPO2=grid%ctopo2 &
-! variables added for BEP
- & ,FRC_URB2D=grid%frc_urb2d &
- & ,A_U_BEP=grid%a_u_bep,A_V_BEP=grid%a_v_bep,A_T_BEP=grid%a_t_bep &
- & ,A_Q_BEP=grid%a_q_bep &
- & ,B_U_BEP=grid%b_u_bep,B_V_BEP=grid%b_v_bep,B_T_BEP=grid%b_t_bep &
- & ,B_Q_BEP=grid%b_q_bep &
- & ,SF_BEP=grid%sf_bep,VL_BEP=grid%vl_bep &
- & ,A_E_BEP=grid%a_e_bep,B_E_BEP=grid%b_e_bep,DLG_BEP=grid%dlg_bep &
- & ,DL_U_BEP=grid%dl_u_bep &
- & ,SF_SFCLAY_PHYSICS=config_flags%sf_sfclay_physics &
- & ,SF_URBAN_PHYSICS=config_flags%sf_urban_physics &
-! Bep changes end
-! add tke_pbl, and turbulent fluxes
- & ,TKE_PBL=grid%tke_pbl,EL_PBL=grid%el_pbl,WU_TUR=grid%wu_tur &
- & ,WV_tur=grid%wv_tur,WT_tur=grid%wt_tur,WQ_tur=grid%wq_tur &
-! end add tke_pbl, and turbulent fluxes
-! GBMPBL change: add exch_tke, rthraten
- & ,EXCH_TKE=grid%exch_tke, RTHRATEN=grid%rthraten &
- & ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &
- & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
- & ,I_START=grid%i_start,I_END=min(grid%i_end, ide-1) &
- & ,J_START=grid%j_start,J_END=min(grid%j_end, jde-1) &
- & ,KTS=k_start, KTE=min(k_end,kde-1) &
- & ,NUM_TILES=grid%num_tiles &
- ! Variables Required by ACM PBL - jp
- & ,ZNU=grid%znu,ZNW=grid%znw,MUT=grid%mut,P_TOP=grid%p_top &
- ! Variables required by TEMF PBL - WA 9/9/08
- ,te_temf=grid%te_temf &
- ,kh_temf=grid%kh_temf,km_temf=grid%km_temf &
- ,shf_temf=grid%shf_temf,qf_temf=grid%qf_temf &
- ,uw_temf=grid%uw_temf,vw_temf=grid%vw_temf &
- ,hd_temf=grid%hd_temf,lcl_temf=grid%lcl_temf &
- ,wupd_temf=grid%wupd_temf,mf_temf=grid%mf_temf &
- ,thup_temf=grid%thup_temf,qtup_temf=grid%qtup_temf &
- ,qlup_temf=grid%qlup_temf &
- ,cf3d_temf=grid%cf3d_temf,cfm_temf=grid%cfm_temf &
- ,hct_temf=grid%hct_temf &
- ,flhc=grid%flhc,flqc=grid%flqc &
- ,exch_temf=exch_temf &
- ! optional
- & ,QV_CURR=moist(ims,kms,jms,P_QV), F_QV=F_QV &
- & ,QC_CURR=moist(ims,kms,jms,P_QC), F_QC=F_QC &
- & ,QR_CURR=moist(ims,kms,jms,P_QR), F_QR=F_QR &
- & ,QI_CURR=moist(ims,kms,jms,P_QI), F_QI=F_QI &
- & ,QS_CURR=moist(ims,kms,jms,P_QS), F_QS=F_QS &
- & ,QG_CURR=moist(ims,kms,jms,P_QG), F_QG=F_QG &
- & ,QNIFA_CURR=scalar(ims,kms,jms,P_QNIFA),F_QNIFA=F_QNIFA &
- & ,QNWFA_CURR=scalar(ims,kms,jms,P_QNWFA),F_QNWFA=F_QNWFA &
- & ,HOL=HOL, MOL=grid%mol, REGIME=grid%REGIME &
-!mynn mp@
- & ,QKE=grid%qke, Sh3d=grid%sh3d &
- & ,QKE_ADV=scalar(ims,kms,jms,P_qke_adv) & !ACF-QKE advection
- & ,bl_mynn_tkeadvect=config_flags%bl_mynn_tkeadvect & !ACF-QKE advection
- & ,tsq=grid%tsq, qsq=grid%qsq, cov=grid%cov &
- & ,DQKE=grid%dqke,QWT=grid%qWT &
- & ,QSHEAR=grid%qSHEAR,QBUOY=grid%qBUOY,QDISS=grid%qDISS &
- & ,bl_mynn_tkebudget=config_flags%bl_mynn_tkebudget &
- & ,bl_mynn_cloudpdf=config_flags%bl_mynn_cloudpdf &
- & ,bl_mynn_mixlength=config_flags%bl_mynn_mixlength &
- & ,icloud_bl=config_flags%icloud_bl &
- & ,qc_bl=grid%qc_bl,qi_bl=grid%qi_bl,cldfra_bl=grid%cldfra_bl &
- & ,bl_mynn_edmf=config_flags%bl_mynn_edmf &
- & ,bl_mynn_edmf_mom=config_flags%bl_mynn_edmf_mom &
- & ,bl_mynn_edmf_tke=config_flags%bl_mynn_edmf_tke &
- & ,bl_mynn_mixscalars=config_flags%bl_mynn_mixscalars &
- & ,bl_mynn_output=config_flags%bl_mynn_output &
- & ,bl_mynn_cloudmix=config_flags%bl_mynn_cloudmix &
- & ,bl_mynn_mixqt=config_flags%bl_mynn_mixqt &
- & ,edmf_a=grid%edmf_a,edmf_w=grid%edmf_w &
- & ,edmf_thl=grid%edmf_thl,edmf_qt=grid%edmf_qt &
- & ,edmf_ent=grid%edmf_ent,edmf_qc=grid%edmf_qc &
- & ,sub_thl3D=grid%sub_thl3D,sub_sqv3D=grid%sub_sqv3D &
- & ,det_thl3D=grid%det_thl3D,det_sqv3D=grid%det_sqv3D &
- & ,rmol=grid%rmol, ch=grid%ch &
- & ,qcg=grid%qcg, grav_settling=config_flags%grav_settling &
-! & ,K_m=grid%K_m, K_h=grid%K_h, K_q=grid%K_q &
- & ,vdfg=grid%vdfg,nupdraft=grid%nupdraft,maxMF=grid%maxmf &
- & ,ktop_plume=grid%ktop_plume &
- & ,spp_pbl=config_flags%spp_pbl &
- & ,pattern_spp_pbl=grid%pattern_spp_pbl &
- & ,restart=config_flags%restart,cycling=config_flags%cycling &
-!EEPS for ARW
- & ,pep=grid%pep_pbl &
- & ,PEK_ADV=scalar(ims,kms,jms,P_pek_adv) &!TKEadvection
- & ,PEP_ADV=scalar(ims,kms,jms,P_pep_adv) &!TKEadvection
-!GWD for ARW
- & ,GWD_OPT=config_flags%gwd_opt &
- & ,gwd_diags=config_flags%gwd_diags &
- & ,DTAUX3D=grid%dtaux3d,DTAUY3D=grid%dtauy3d &
- & ,DUSFCG=grid%dusfcg,DVSFCG=grid%dvsfcg &
- & ,VAR2D=grid%var2d,OC12D=grid%oc12d &
- & ,OA1=grid%oa1,OA2=grid%oa2,OA3=grid%oa3,OA4=grid%oa4 &
- & ,OL1=grid%ol1,OL2=grid%ol2,OL3=grid%ol3,OL4=grid%ol4 &
- & ,SINA=grid%sina,COSA=grid%cosa &
- & ,dtaux3d_ls=grid%dtaux3d_ls,dtauy3d_ls=grid%dtauy3d_ls &
- & ,dtaux3d_bl=grid%dtaux3d_bl,dtauy3d_bl=grid%dtauy3d_bl &
- & ,dtaux3d_ss=grid%dtaux3d_ss,dtauy3d_ss=grid%dtauy3d_ss &
- & ,dtaux3d_fd=grid%dtaux3d_fd,dtauy3d_fd=grid%dtauy3d_fd &
- & ,DUSFCG_ls=grid%dusfcg_ls,DVSFCG_ls=grid%dvsfcg_ls &
- & ,DUSFCG_bl=grid%dusfcg_bl,DVSFCG_bl=grid%dvsfcg_bl &
- & ,DUSFCG_ss=grid%dusfcg_ss,DVSFCG_ss=grid%dvsfcg_ss &
- & ,DUSFCG_fd=grid%dusfcg_fd,DVSFCG_fd=grid%dvsfcg_fd &
- & ,VAR2DLS=grid%var2dls,OC12DLS=grid%oc12dls &
- & ,OA1LS=grid%oa1ls,OA2LS=grid%oa2ls,OA3LS=grid%oa3ls &
- & ,OA4LS=grid%oa4ls,OL1LS=grid%ol1ls,OL2LS=grid%ol2ls &
- & ,OL3LS=grid%ol3ls,OL4LS=grid%ol4ls &
- & ,VAR2DSS=grid%var2dss,OC12DSS=grid%oc12dss &
- & ,OA1SS=grid%oa1ss,OA2SS=grid%oa2ss,OA3SS=grid%oa3ss &
- & ,OA4SS=grid%oa4ss,OL1SS=grid%ol1ss,OL2SS=grid%ol2ss &
- & ,OL3SS=grid%ol3ss,OL4SS=grid%ol4ss &
- & ,MFSHCONV=config_flags%mfshconv &
- & ,MASSFLUX_EDKF=grid%massflux_EDKF &
- & ,ENTR_EDKF=grid%entr_EDKF, DETR_EDKF=grid%detr_EDKF &
- & ,THL_UP=grid%thl_up &
- & ,THV_UP=grid%thv_up, RT_UP=grid%rt_up ,RV_UP=grid%rv_up &
- & ,RC_UP=grid%rc_up, U_UP=grid% u_up, V_UP=grid%v_up &
- & ,FRAC_UP=grid%frac_up, RC_MF=grid%RC_MF &
-! For Wind Turbine Drag Parameterizations
- & ,phb=grid%phb &
- & ,XLAT_U=grid%xlat_u,XLONG_U=grid%xlong_u &
-!Variables required for camuwpbl scheme
- & ,Z_AT_W=grid%z_at_w,CLDFRA_OLD_MP=grid%cldfra_old_mp &
- & ,CLDFRA=grid%cldfra &
- & ,RTHRATENLW=grid%rthratenlw,TAURESX2D=grid%tauresx2d &
- & ,TAURESY2D=grid%tauresy2d &
- & ,TPERT2D=grid%tpert2d,QPERT2D=grid%qpert2d &
- & ,WPERT2D=grid%wpert2d,WSEDL3D=grid%wsedl3d &
- & ,TURBTYPE3D=grid%turbtype3d,SMAW3D=grid%smaw3d &
- & ,QNC_CURR=scalar(ims,kms,jms,P_QNC), F_QNC=f_qnc &
- & ,QNI_CURR=scalar(ims,kms,jms,P_QNI), F_QNI=f_qni &
- & ,RQNIBLTEN=grid%rqniblten &
- & ,XLAT_V=grid%xlat_v,XLONG_V=grid%xlong_v,FNM=grid%fnm &
- & ,FNP=grid%fnp, IS_CAMMGMP_USED = grid%is_CAMMGMP_used &
-! for grims shallow convection with ysupbl
- & ,WSTAR=grid%wstar_ysu,DELTA=grid%delta_ysu &
-! for pbl mixing of scalars and tracers
- & ,SCALAR=scalar,SCALAR_TEND=scalar_tend,NUM_SCALAR=num_scalar&
- & ,TRACER=tracer,TRACER_TEND=tracer_tend,NUM_TRACER=num_tracer&
- & ,SCALAR_PBLMIX=config_flags%scalar_pblmix &
- & ,TRACER_PBLMIX=config_flags%tracer_pblmix &
-#if (WRF_CHEM == 1)
- & ,CHEM=chem,VD=grid%dep_vel &
- & ,NCHEM=num_chem,kdvel=config_flags%kdepvel &
- & ,ndvel=config_flags%ndepvel &
- & ,NUM_VERT_MIX=grid%num_vert_mix &
-#endif
- & ,QNORM=grid%QNORM, fasdas=config_flags%fasdas & !fasdas
- & )
-
-#if (WRF_CHEM == 1)
-#ifdef DM_PARALLEL
- IF ( num_chem >= PARAM_FIRST_SCALAR .AND. (config_flags%bl_pbl_physics == &
- & mynnpblscheme2 .OR. config_flags%bl_pbl_physics == mynnpblscheme3) ) then
- CALL wrf_debug ( 200 , ' call HALO CHEM AFTER PBL' )
- IF ( config_flags%h_sca_adv_order <= 4 ) THEN
-# include "HALO_EM_CHEM_E_3.inc"
- ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
-# include "HALO_EM_CHEM_E_5.inc"
- ELSE
- WRITE(message,*)'solve_em: invalid h_sca_adv_order = ',&
- & config_flags%h_sca_adv_order
- ENDIF
- ENDIF
-#endif
-#endif
-
-BENCH_END(pbl_driver_tim)
-
-!*****
-! fire
-
-! Jan Mandel's call to SFIRE
-
- IF ((grid%sr_x > 0 .OR. grid%sr_y > 0) .AND. config_flags%ifire == 2) THEN
-
-BENCH_START(fire_driver_tim)
- if(config_flags%ifire.eq.2)then
- ! initialization moved to start_em:start_domain_em
-! if(grid%initestep.eq.1) &
-! call fire_driver_em_init ( grid , config_flags &
-! ,ids,ide, kds,kde, jds,jde &
-! ,ims,ime, kms,kme, jms,jme &
-! ,ips,ipe, kps,kpe, jps,jpe )
- ! one timestep of the fire model
- call fire_driver_em_step ( grid , config_flags &
- ,ids,ide, kds,kde, jds,jde &
- ,ims,ime, kms,kme, jms,jme &
- ,ips,ipe, kps,kpe, jps,jpe &
- ,grid%rho,grid%z_at_w,dz8w)
- endif
-
-BENCH_END(fire_driver_tim)
- ENDIF
-
-
-! cumulus para.
-
- CALL wrf_debug ( 200 , ' call cumulus_driver' )
-
-#if ( WRF_DFI_RADAR == 1 )
- do_capsupress=0
- if(grid%dfi_stage == DFI_FWD ) do_capsupress=1
- if(grid%itimestep <= 31 .and. grid%dfi_stage == DFI_FST ) do_capsupress=1
-#endif
-
-BENCH_START(cu_driver_tim)
- CALL cumulus_driver(grid &
- ! Prognostic variables
- & ,U=grid%u_phy ,V=grid%v_phy ,TH=th_phy ,T=grid%t_phy &
- & ,W=grid%w_2 ,P=grid%p_hyd ,PI=pi_phy ,RHO=grid%rho &
- ! Other arguments
- & ,ITIMESTEP=grid%itimestep ,DT=grid%dt ,DX=grid%dx &
- & ,DX2D=grid%dx2d, AREA2D=grid%area2d &
- & ,CUDT=grid%cudt,CURR_SECS=curr_secs,ADAPT_STEP_FLAG=adapt_step_flag &
- & ,CCLDFRA=grid%ccldfra ,CONVCLD=grid%convcld &
- & ,QCCONV=grid%qcconv ,QICONV=grid%qiconv &
- & ,CUDTACTTIME=grid%cudtacttime &
- & ,RAINC=grid%rainc ,RAINCV=grid%raincv ,PRATEC=grid%pratec &
- & ,NCA=grid%nca &
- & ,CLDFRA_DP=grid%cldfra_dp ,CLDFRA_SH=grid%cldfra_sh &
- & ,QC_CU=grid%QC_CU, QI_CU=grid%QI_CU, QR_CU=grid%QR_CU, QS_CU=grid%QS_CU &
- & ,NC_CU=grid%NC_CU, NI_CU=grid%NI_CU, NR_CU=grid%NR_CU, NS_CU=grid%NS_CU &
- & ,CCN_CU=grid%CCN_CU, CU_UAF=grid%CU_UAF &
- & ,UDR_KF=grid%udr_kf,DDR_KF=grid%ddr_kf & ! kf_edrates
- & ,UER_KF=grid%uer_kf,DER_KF=grid%der_kf,TIMEC_KF=grid%timec_kf &
- & ,KF_EDRATES=config_flags%kf_edrates &
- & ,HTOP=grid%cutop ,HBOT=grid%cubot ,KPBL=grid%kpbl &
- & ,Z=grid%z ,Z_AT_W=grid%z_at_w ,MAVAIL=grid%mavail ,PBLH=grid%pblh &
- & ,HPBL_HOLD=hpbl_hold &
- & ,DZ8W=dz8w ,P8W=grid%p_hyd_w, PSFC=grid%psfc, TSK=grid%tsk &
- & ,TKE_PBL=grid%tke_pbl, UST=grid%ust &
- & ,W0AVG=grid%w0avg ,STEPCU=grid%stepcu &
- & ,CLDEFI=grid%cldefi ,LOWLYR=grid%lowlyr ,XLAND=grid%xland &
- & ,APR_GR=grid%apr_gr ,APR_W=grid%apr_w ,APR_MC=grid%apr_mc &
- & ,APR_ST=grid%apr_st ,APR_AS=grid%apr_as ,APR_CAPMA=grid%apr_capma &
- & ,APR_CAPME=grid%apr_capme ,APR_CAPMI=grid%apr_capmi &
- & ,MASS_FLUX=grid%mass_flux ,XF_ENS=grid%xf_ens &
- & ,PR_ENS=grid%pr_ens ,HT=grid%ht,EDT_OUT=grid%edt_out &
- & ,imomentum=grid%imomentum,clos_choice=grid%clos_choice &
- & ,ishallow=config_flags%ishallow &
- & ,cugd_tten=grid%cugd_tten,cugd_qvten=grid%cugd_qvten,cugd_qcten=grid%cugd_qcten &
- & ,cugd_ttens=grid%cugd_ttens,cugd_qvtens=grid%cugd_qvtens &
- & ,ENSDIM=config_flags%ensdim ,MAXIENS=config_flags%maxiens ,MAXENS=config_flags%maxens &
- & ,MAXENS2=config_flags%maxens2 ,MAXENS3=config_flags%maxens3 &
- & ,CU_ACT_FLAG=cu_act_flag ,WARM_RAIN=grid%warm_rain &
- & ,HFX=grid%hfx, QFX=grid%qfx &
- & ,CLDFRA=grid%cldfra,CLDFRA_MP_ALL=grid%cldfra_mp_all &
- & ,TPERT2D=grid%tpert2d &
- & ,GSW=grid%gsw,cugd_avedx=config_flags%cugd_avedx &
- !BSINGH - For WRFCuP scheme
- & ,AKPBL=grid%akpbl,BR=grid%br, REGIME=grid%regime, T2=grid%t2, Q2=grid%q2 & !CuP, wig 3-Aug-2006
- & ,SLOPESFC=grid%slopeSfc, SLOPEEZ=grid%slopeEZ & !CuP, wig 7-Aug-2006
- & ,SIGMASFC=grid%sigmaSfc, SIGMAEZ=grid%sigmaEZ & !CuP, wig 7-Aug-2006
- & ,CUPFLAG=grid%cupflag & !CuP, wig 9-Oct-2006
- & ,CLDFRA_CUP=grid%cldfra_cup, CLDFRATEND_CUP=grid%cldfratend_cup & !CuP, wig 18-Sep-2006
- & ,SHALL=grid%shall, TAUCLOUD=grid%taucloud, TACTIVE=grid%tactive & !CuP, wig 18-Sep-2006
- & ,TSTAR=grid%tstar, LNTERMS=grid%lnterms, LNINT=grid%lnint & !CuP, wig 4-Oct-2006
- & ,ACTIVEFRAC=grid%activeFrac & !CuP, lkb
- & ,NUMBINS=config_flags%numBins & !CuP, wig
- & ,THBINSIZE=config_flags%thBinSize & !CuP, wig
- & ,RBINSIZE=config_flags%rBinSize & !CuP, wig
- & ,MINDEEPFREQ=config_flags%minDeepFreq & !CuP, wig
- & ,MINSHALLOWFREQ=config_flags%minShallowFreq & !CuP, wig
- & ,WCLOUDBASE=grid%wCloudBase & !CuP, lkb
- & ,WACT_CUP=grid%wact_cup & !CuP, rce 25-aug-2011
- & ,WULCL_CUP=grid%wulcl_cup & !CuP, rce 23-jan-2012
- & ,WUP_CUP=grid%wup_cup & !CuP, rce 15-mar-2013 !BSINGH(12/05/2013)
- & ,QC_IC_CUP=grid%qc_ic_cup & !CuP, rce 29-aug-2011
- & ,QNDROP_IC_CUP=grid%qndrop_ic_cup & !CuP, rce 29-aug-2011
- & ,QC_IU_CUP=grid%qc_iu_cup & !CuP, rce 08-feb-2012
- & ,FCVT_QC_TO_PR_CUP=grid%fcvt_qc_to_pr_cup & !CuP, rce 12-apr-2012
- & ,FCVT_QC_TO_QI_CUP=grid%fcvt_qc_to_qi_cup & !CuP, rce 12-apr-2012
- & ,FCVT_QI_TO_PR_CUP=grid%fcvt_qi_to_pr_cup & !CuP, rce 12-apr-2012
- & ,MFUP_CUP=grid%mfup_cup & !CuP, rce 23-jan-2012
- & ,MFUP_ENT_CUP=grid%mfup_ent_cup & !CuP, rce 23-jan-2012
- & ,MFDN_CUP=grid%mfdn_cup & !CuP, rce 12-apr-2012
- & ,MFDN_ENT_CUP=grid%mfdn_ent_cup & !CuP, rce 12-apr-2012
- & ,UPDFRA_CUP=grid%updfra_cup & !CuP, rce 23-jan-2012
- & ,TCLOUD_CUP=grid%tcloud_cup & !CuP, rce 06-feb-2012
- !BSINGH -ENDS
- & ,k22_shallow=grid%k22_shallow,kbcon_shallow=grid%kbcon_shallow &
- & ,ktop_shallow=grid%ktop_shallow,xmb_shallow=grid%xmb_shallow &
- & ,ktop_deep=grid%ktop_deep &
- & ,PERIODIC_X=(config_flags%polar .OR. config_flags%periodic_x) &
- & ,PERIODIC_Y=config_flags%periodic_y &
- & ,IS_CAMMGMP_USED = grid%is_CAMMGMP_used & !BSINGH - TKE at the interfaces for Zhang-McFarlane Scheme
- ! Zhang-McFarlane outputs
- & ,EVAPCDP3D=grid%evapcdp3d, ICWMRDP3D=grid%icwmrdp3d & !Balwinder.Singh@pnnl.gov: For CAM's wetscavenging
- & ,RPRDDP3D=grid%rprddp3d &
- & ,CAPE=grid%cape ,ZMMU=grid%zmmu ,ZMMD=grid%zmmd &
- & ,ZMDT=grid%zmdt ,ZMDQ=grid%zmdq &
- & ,DLF=grid%dlf, RLIQ=grid%rliq &
- & ,PCONVB=grid%pconvb, PCONVT=grid%pconvt &
- & ,EVAPTZM=grid%evaptzm, FZSNTZM=grid%fzsntzm, EVSNTZM=grid%evsntzm &
- & ,EVAPQZM=grid%evapqzm, ZMFLXPRC=grid%zmflxprc &
- & ,ZMFLXSNW=grid%zmflxsnw, ZMNTPRPD=grid%zmntprpd &
- & ,ZMNTSNPD=grid%zmntsnpd, ZMEIHEAT=grid%zmeiheat &
- & ,CMFMC=grid%cmfmc, CMFMCDZM=grid%cmfmcdzm &
- & ,PRECCDZM=grid%preccdzm, PRECZ=grid%precz &
- & ,ZMMTU=grid%zmmtu, ZMMTV=grid%zmmtv &
- & ,ZMUPGU=grid%zmupgu, ZMUPGD=grid%zmupgd &
- & ,ZMVPGU=grid%zmvpgu, ZMVPGD=grid%zmvpgd &
- & ,ZMICUU=grid%zmicuu, ZMICUD=grid%zmicud &
- & ,ZMICVU=grid%zmicvu, ZMICVD=grid%zmicvd &
- & ,ZMDICE=grid%zmdice, ZMDLIQ=grid%zmdliq &
- & ,dp3d=grid%dp3d, du3d=grid%du3d, ed3d=grid%ed3d &
- & ,eu3d=grid%eu3d, md3d=grid%md3d, mu3d=grid%mu3d &
- & ,dsubcld2d=grid%dsubcld2d,ideep2d=grid%ideep2d &
- & ,jt2d=grid%jt2d,maxg2d=grid%maxg2d &
- & ,lengath2d=grid%lengath2d &
- ! Selection flag
- & ,pgcon=config_flags%sas_pgcon &
- & ,BMJ_RAD_FEEDBACK=config_flags%bmj_rad_feedback &
- & ,CU_PHYSICS=config_flags%cu_physics &
- & ,BL_PBL_PHYSICS=config_flags%bl_pbl_physics &
- & ,SF_SFCLAY_PHYSICS=config_flags%sf_sfclay_physics &
- !BSINGH - For WRFCuP scheme
- & ,SHCU_AEROSOLS_OPT=config_flags%shcu_aerosols_opt & !CuP, rce 22-aug-2011
- !BSINGH -ENDS
- & ,KFETA_TRIGGER=config_flags%kfeta_trigger &
- & ,NSAS_DX_FACTOR=config_flags%nsas_dx_factor &
- ! Dimension arguments
- & ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &
- & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
- & ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe &
- & ,I_START=grid%i_start,I_END=min(grid%i_end, ide-1) &
- & ,J_START=grid%j_start,J_END=min(grid%j_end, jde-1) &
- & ,KTS=k_start, KTE=min(k_end,kde-1) &
- & ,NUM_TILES=grid%num_tiles &
- ! Moisture tendency arguments
- & ,RQVCUTEN=grid%rqvcuten , RQCCUTEN=grid%rqccuten &
- & ,RQSCUTEN=grid%rqscuten , RQICUTEN=grid%rqicuten &
- & ,RQRCUTEN=grid%rqrcuten , RQCNCUTEN=grid%rqcncuten &
- & ,RQINCUTEN=grid%rqincuten &
- & ,RQVBLTEN=grid%rqvblten , RQVFTEN=grid%rqvften &
- ! Other tendency arguments
- & ,RTHRATEN=grid%rthraten , RTHBLTEN=grid%rthblten &
- & ,RUCUTEN=grid%rucuten , RVCUTEN=grid%rvcuten &
- & ,RTHCUTEN=grid%rthcuten , RTHFTEN=grid%rthften &
- ! Moisture tracer arguments
- & ,QV_CURR=moist(ims,kms,jms,P_QV), F_QV=F_QV &
- & ,QC_CURR=moist(ims,kms,jms,P_QC), F_QC=F_QC &
- & ,QR_CURR=moist(ims,kms,jms,P_QR), F_QR=F_QR &
- & ,QI_CURR=moist(ims,kms,jms,P_QI), F_QI=F_QI &
- & ,QS_CURR=moist(ims,kms,jms,P_QS), F_QS=F_QS &
- & ,QG_CURR=moist(ims,kms,jms,P_QG), F_QG=F_QG &
- & ,ZOL=grid%ZOL & !ckay
-! Variables for Tiedtke and NSAS schemes
- & ,ZNU=grid%znu &
- & ,MP_PHYSICS=config_flags%mp_physics &
- & ,GD_CLOUD=grid%GD_CLOUD,GD_CLOUD2=grid%GD_CLOUD2 &
-#if (WRF_CHEM == 1)
- & ,CHEM_OPT=config_flags%chem_opt & !CuP, rce 22-aug-2011 !BSINGH - For WRFCuP scheme
- & ,CONV_TR_WETSCAV=config_flags%conv_tr_wetscav &
- & ,CONV_TR_AQCHEM=config_flags%conv_tr_aqchem &
- & ,CHEM_CONV_TR=config_flags%chem_conv_tr &
- & ,TRACEROPT=config_flags%tracer_opt &
-#endif
-
-#if ( WRF_DFI_RADAR == 1 )
- & ,DO_CAPSUPPRESS=do_capsupress &
-#endif
- & ,cfu1=grid%cfu1,cfd1=grid%cfd1,dfu1=grid%dfu1,efu1=grid%efu1,dfd1=grid%dfd1,efd1=grid%efd1,f_flux=l_flux &
- ,alevsiz_cu=grid%alevsiz_cu,num_months=grid%num_months &
- ,no_src_types_cu=grid%no_src_types_cu &
- ,aercu_opt=config_flags%aercu_opt &
- ,aercu_fct=config_flags%aercu_fct &
- ,aeromcu=grid%aeromcu,aerocu=aerocu(:,:,:,P_cu_sulfate:P_cu_phibcar) &
- ,aeropcu=grid%aeropcu,ID=grid%id &
- ,JULDAY=grid%julday, JULIAN=grid%julian &
- ,aerovar=grid%aerovar,EFCS=grid%EFCS,EFIS=grid%EFIS,EFSS=grid%EFSS)
-BENCH_END(cu_driver_tim)
-!
-! this for calculating (G3 scheme only) time averaged variables for online (WRF-CHem) or offline (other models) chem runs
-!
- if(config_flags%cu_diag.eq.1)then
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
- call convtrans_prep(grid%gd_cloud,grid%gd_cloud2,grid%gd_cloud_a,&
- & grid%QC_CU,grid%raincv,grid%raincv_a,grid%raincv_b, &
- & grid%gd_cldfr,moist,p_QV,p_QC,p_qi,T_PHY,P_PHY,num_moist, &
- & grid%gd_cloud2_a,grid%QI_CU,grid%convtrans_avglen_m,&
- & adapt_step_flag,curr_secs, &
- & grid%itimestep,grid%dt, &
- & config_flags%cu_physics, &
- & ids,ide, jds,jde, kds,kde, &
- & ims,ime, jms,jme, kms,kme &
- & ,ITS=grid%i_start(ij),ITE=min(grid%i_end(ij), ide-1) &
- & ,JTS=grid%j_start(ij),JTE=min(grid%j_end(ij), jde-1) &
- & ,KTS=k_start, KTE=min(k_end,kde-1))
- ENDDO
- !$OMP END PARALLEL DO
- endif
-
-! shallow cumulus parameterization
- CALL wrf_debug ( 200 , ' call shallow_cumulus_driver' )
-
-BENCH_START(shcu_driver_tim)
- CALL shallowcu_driver( &
- & IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &
- & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
- & ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe &
- & ,I_START=grid%i_start, I_END=min(grid%i_end, ide-1) &
- & ,J_START=grid%j_start, J_END=min(grid%j_end, jde-1) &
- & ,KTS=k_start, KTE=min(k_end, kde-1) &
- & ,NUM_TILES=grid%num_tiles &
- & ,U=grid%u_phy, V=grid%v_phy, TH=th_phy, T=t_phy &
- & ,P=grid%p_hyd, PI=pi_phy, RHO=grid%rho, MOIST=moist &
- & ,NUM_MOIST=num_moist &
- & ,ITIMESTEP=grid%itimestep, DT=grid%dt, DX=grid%dx &
- & ,DX2D=grid%dx2d, AREA2D=grid%area2d &
- & ,CUDT=grid%cudt &
- & ,CURR_SECS=curr_secs, ADAPT_STEP_FLAG=adapt_step_flag &
- & ,RAINSH=grid%rainsh, PRATESH=grid%pratesh, NCA=grid%nca&
- & ,RAINSHV=grid%rainshv &
- & ,Z=grid%z, Z_AT_W=grid%z_at_w, DZ8W=dz8w &
- & ,MAVAIL=grid%mavail, PBLH=grid%pblh, P8W=grid%p_hyd_w &
- & ,TKE_PBL=grid%tke_pbl &
- & ,CLDFRA=grid%cldfra, CLDFRA_OLD=grid%cldfra_old &
- & ,CLDFRA_OLD_MP=grid%cldfra_old_mp &
- & ,CLDFRA_CONV=grid%cldfra_conv &
- & ,CLDFRASH=grid%cldfrash, HTOP=grid%htop, HBOT=grid%hbot&
- & ,SHCU_PHYSICS=grid%shcu_physics &
- & ,QV_CURR=moist(ims,kms,jms,P_QV) &
- & ,QC_CURR=moist(ims,kms,jms,P_QC) &
- & ,QR_CURR=moist(ims,kms,jms,P_QR) &
- & ,QI_CURR=moist(ims,kms,jms,P_QI) &
- & ,QS_CURR=moist(ims,kms,jms,P_QS) &
- & ,QG_CURR=moist(ims,kms,jms,P_QG) &
- & ,QNC_CURR=scalar(ims,kms,jms,P_QNC) & !BSINGH - Neede for UWSHCU scheme
- & ,QNI_CURR=scalar(ims,kms,jms,P_QNI) & !BSINGH - Neede for UWSHCU schem
-#if (WRF_CHEM == 1)
- & ,CHEM=chem,chem_opt=config_flags%chem_opt &
-#endif
- & ,DLF=grid%dlf, RLIQ=grid%rliq, RLIQ2=grid%rliq2 &
- & ,DLF2=grid%dlf2 & ! Required for CAMMGMP microphysics scheme
- & ,CMFMC=grid%cmfmc, CMFMC2=grid%cmfmc2 &
- & ,CUSH=grid%cush, SNOWSH=grid%snowsh &
- & ,ICWMRSH=grid%icwmrsh, RPRDSH=grid%rprdsh &
- & ,CBMF=grid%cbmf_cu, CMFSL=grid%cmfsl, CMFLQ=grid%cmflq &
- & ,EVAPCSH=grid%evapcsh &
- & ,RQVSHTEN=grid%rqvshten, RQCSHTEN=grid%rqcshten &
- & ,RQRSHTEN=grid%rqrshten, RQISHTEN=grid%rqishten &
- & ,RQSSHTEN=grid%rqsshten, RQGSHTEN=grid%rqgshten &
- & ,RQCNSHTEN=grid%rqcnshten, RQINSHTEN=grid%rqinshten &
- & ,RQVBLTEN=grid%rqvblten, RQVFTEN=grid%rqvften &
- & ,RUSHTEN=grid%rushten, RVSHTEN=grid%rvshten &
- & ,RTHSHTEN=grid%rthshten, RTHRATEN=grid%rthraten &
- & ,RTHBLTEN=grid%rthblten, RTHFTEN=grid%rthften &
- & ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr &
- & ,F_QI=f_qi,F_QS=f_qs,F_QG=f_qg &
- & ,HT=grid%ht &
- & ,SHFRC3D=grid%shfrc3d & !Balwinder.Singh@pnnl.gov: For CAM's wetscavenging
- & ,IS_CAMMGMP_USED = grid%is_CAMMGMP_used &
- & ,WSTAR=grid%wstar_ysu,DELTA=grid%delta_ysu &
- & ,KPBL=grid%kpbl,ZNU=grid%znu &
- & ,RAINCV=grid%raincv &
- & ,W=grid%w_2 ,XLAND=grid%xland &
- & ,HFX=grid%hfx, QFX=grid%qfx &
- & ,MP_PHYSICS=config_flags%mp_physics &
- & ,pgcon=config_flags%sas_pgcon &
- & ,RDCASHTEN=grid%RDCASHTEN, RQCDCSHTEN=grid%RQCDCSHTEN & ! Deng sh
- & ,W0AVG=grid%W0AVG &
- & ,clddpthb=grid%clddpthb, cldtopb=grid%cldtopb &
- & ,cldareaa=grid%cldareaa, cldareab=grid%cldareab &
- & ,cldliqa=grid%cldliqa, cldliqb=grid%cldliqb &
- & ,cldfra_sh=grid%cldfra_sh,ca_rad=grid%ca_rad, cw_rad=grid%cw_rad &
- & ,wub=grid%wub, pblmax=grid%pblmax, xlong=grid%xlong &
- & ,rainshvb=grid%rainshvb, capesave=grid%capesave &
- & ,radsave=grid%radsave, ainckfsa=grid%ainckfsa &
- & ,ltopb=grid%ltopb, kdcldtop=grid%kdcldtop &
- & ,kdcldbas=grid%kdcldbas &
- & ,el_pbl=grid%el_pbl &
- & ,rthratenlw=grid%rthratenlw, rthratensw=grid%rthratensw &
- & ,exch_h=grid%exch_h &
- & ,dnw=grid%dnw, XTIME=grid%XTIME, XTIME1=grid%XTIME1 &
- & ,GMT=grid%gmt &
- & ,qke=grid%qke &
- & ,PBLHAVG=grid%PBLHAVG, TKEAVG=grid%TKEAVG &
- & ,BL_PBL_PHYSICS=config_flags%bl_pbl_physics &
- & )
-
-#if (WRF_CHEM == 1)
-#ifdef DM_PARALLEL
- IF( config_flags%shcu_physics == CAMUWSHCUSCHEME ) THEN
- CALL wrf_debug ( 200 , ' call HALO CHEM AFTER SHALLOW CUMULUS' )
- IF ( config_flags%h_sca_adv_order <= 4 ) THEN
-# include "HALO_EM_CHEM_E_3.inc"
- ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
-# include "HALO_EM_CHEM_E_5.inc"
- ELSE
- WRITE(message,*)'module_first_rk_step_part1: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
- CALL wrf_error_fatal(TRIM(message))
- ENDIF
- ENDIF
-#endif
-#endif
-BENCH_END(shcu_driver_tim)
-
-! JPH call force_scm to update bl tendencies
- CALL force_scm(itimestep=grid%itimestep,dt=grid%dt &
- & ,scm_force=config_flags%scm_force &
- & ,dx=config_flags%scm_force_dx &
- & ,num_force_layers=grid%num_force_layers &
- & ,scm_th_adv=config_flags%scm_th_adv &
- & ,scm_qv_adv=config_flags%scm_qv_adv &
- & ,scm_ql_adv=config_flags%scm_ql_adv &
- & ,scm_wind_adv=config_flags%scm_wind_adv &
- & ,scm_vert_adv=config_flags%scm_vert_adv &
- & ,scm_th_t_tend=config_flags%scm_th_t_tend &
- & ,scm_qv_t_tend=config_flags%scm_qv_t_tend &
- & ,scm_soilT_force=config_flags%scm_soilT_force &
- & ,scm_soilQ_force=config_flags%scm_soilQ_force &
- & ,scm_force_th_largescale=config_flags%scm_force_th_largescale &
- & ,scm_force_qv_largescale=config_flags%scm_force_qv_largescale &
- & ,scm_force_ql_largescale=config_flags%scm_force_ql_largescale &
- & ,scm_force_wind_largescale=config_flags%scm_force_wind_largescale &
- & ,u_base=grid%u_base,v_base=grid%v_base &
- & ,z_base=grid%z_base &
- & ,z_force=grid%z_force,z_force_tend=grid%z_force_tend &
- & ,u_g=grid%u_g,v_g=grid%v_g &
- & ,u_g_tend=grid%u_g_tend,v_g_tend=grid%v_g_tend &
- & ,w_subs=grid%w_subs, w_subs_tend=grid%w_subs_tend &
- & ,th_upstream_x=grid%th_upstream_x &
- & ,th_upstream_x_tend=grid%th_upstream_x_tend &
- & ,th_upstream_y=grid%th_upstream_y &
- & ,th_upstream_y_tend=grid%th_upstream_y_tend &
- & ,qv_upstream_x=grid%qv_upstream_x &
- & ,qv_upstream_x_tend=grid%qv_upstream_x_tend &
- & ,qv_upstream_y=grid%qv_upstream_y &
- & ,qv_upstream_y_tend=grid%qv_upstream_y_tend &
- & ,ql_upstream_x=grid%ql_upstream_x &
- & ,ql_upstream_x_tend=grid%ql_upstream_x_tend &
- & ,ql_upstream_y=grid%ql_upstream_y &
- & ,ql_upstream_y_tend=grid%ql_upstream_y_tend &
- & ,u_upstream_x=grid%u_upstream_x &
- & ,u_upstream_x_tend=grid%u_upstream_x_tend &
- & ,u_upstream_y=grid%u_upstream_y &
- & ,u_upstream_y_tend=grid%u_upstream_y_tend &
- & ,v_upstream_x=grid%v_upstream_x &
- & ,v_upstream_x_tend=grid%v_upstream_x_tend &
- & ,v_upstream_y=grid%v_upstream_y &
- & ,v_upstream_y_tend=grid%v_upstream_y_tend &
- & ,th_t_tend=grid%th_t_tend &
- & ,qv_t_tend=grid%qv_t_tend &
- & ,tau_x=grid%tau_x &
- & ,tau_x_tend=grid%tau_x_tend &
- & ,tau_y=grid%tau_y &
- & ,tau_y_tend=grid%tau_y_tend &
- & ,th_largescale=grid%th_largescale &
- & ,th_largescale_tend=grid%th_largescale_tend &
- & ,qv_largescale=grid%qv_largescale &
- & ,qv_largescale_tend=grid%qv_largescale_tend &
- & ,ql_largescale=grid%ql_largescale &
- & ,ql_largescale_tend=grid%ql_largescale_tend &
- & ,u_largescale=grid%u_largescale &
- & ,u_largescale_tend=grid%u_largescale_tend &
- & ,v_largescale=grid%v_largescale &
- & ,v_largescale_tend=grid%v_largescale_tend &
- & ,tau_largescale=grid%tau_largescale &
- & ,tau_largescale_tend=grid%tau_largescale_tend &
- & ,num_force_soil_layers=config_flags%num_force_soil_layers &
- & ,num_soil_layers=config_flags%num_soil_layers &
- & ,soil_depth_force=grid%soil_depth_force &
- & ,zs=grid%zs &
- & ,tslb=grid%tslb,smois=grid%smois &
- & ,t_soil_forcing_val=grid%t_soil_forcing_val &
- & ,t_soil_forcing_tend=grid%t_soil_forcing_tend &
- & ,q_soil_forcing_val=grid%q_soil_forcing_val &
- & ,q_soil_forcing_tend=grid%q_soil_forcing_tend &
- & ,tau_soil=grid%tau_soil &
- & ,z=grid%z,z_at_w=grid%z_at_w &
- & ,th=th_phy, qv=moist(ims,kms,jms,P_QV) &
- & ,ql=moist(ims,kms,jms,P_QC) &
- & ,u=grid%u_phy, v=grid%v_phy &
- & ,thten=grid%rthblten, qvten=grid%rqvblten &
- & ,qlten=grid%rqcblten &
- & ,uten=grid%rublten, vten=grid%rvblten &
- & ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &
- & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
- & ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe &
- & ,KTS=k_start, KTE=min(k_end,kde-1) &
- & )
-
-#ifdef DM_PARALLEL
-# include "HALO_EM_FDDA_SFC.inc"
-#endif
- CALL wrf_debug ( 200 , ' call fddagd_driver' )
-
-BENCH_START(fdda_driver_tim)
- CALL fddagd_driver(itimestep=grid%itimestep,dt=grid%dt,xtime=grid%XTIME, &
- id=grid%id, &
- RUNDGDTEN=grid%rundgdten,RVNDGDTEN=grid%rvndgdten, &
- RTHNDGDTEN=grid%rthndgdten,RPHNDGDTEN=grid%rphndgdten, &
- RQVNDGDTEN=grid%rqvndgdten,RMUNDGDTEN=grid%rmundgdten, &
-!
-! FASDAS
-!
- SDA_HFX=grid%SDA_HFX, SDA_QFX=grid%SDA_QFX, &
- HFX_FDDA=grid%HFX_FDDA, &
-!
-! END FASDAS
-!
- u_ndg_old=fdda3d(ims,kms,jms,P_u_ndg_old), &
- v_ndg_old=fdda3d(ims,kms,jms,P_v_ndg_old), &
- t_ndg_old=fdda3d(ims,kms,jms,P_t_ndg_old), &
- ph_ndg_old=fdda3d(ims,kms,jms,P_ph_ndg_old), &
- q_ndg_old=fdda3d(ims,kms,jms,P_q_ndg_old), &
- mu_ndg_old=fdda2d(ims,1,jms,P_mu_ndg_old), &
- u_ndg_new=fdda3d(ims,kms,jms,P_u_ndg_new), &
- v_ndg_new=fdda3d(ims,kms,jms,P_v_ndg_new), &
- t_ndg_new=fdda3d(ims,kms,jms,P_t_ndg_new), &
- ph_ndg_new=fdda3d(ims,kms,jms,P_ph_ndg_new), &
- q_ndg_new=fdda3d(ims,kms,jms,P_q_ndg_new), &
- mu_ndg_new=fdda2d(ims,1,jms,P_mu_ndg_new), &
- u3d=grid%u_2,v3d=grid%v_2,th_phy=th_phy, &
- ph=grid%ph_2,rho=grid%rho,moist=moist, &
- p_phy=p_phy,pi_phy=pi_phy,p8w=p8w,t_phy=grid%t_phy, &
- dz8w=dz8w,z=grid%z,z_at_w=grid%z_at_w, &
- grid=grid,config_flags=config_flags,dx=grid%DX,n_moist=num_moist, &
- STEPFG=grid%STEPFG, &
- pblh=grid%pblh,ht=grid%ht,REGIME=grid%regime,ZNT=grid%znt &
- ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &
- ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
- ,I_START=grid%i_start,I_END=min(grid%i_end, ide-1) &
- ,J_START=grid%j_start,J_END=min(grid%j_end, jde-1) &
- ,KTS=k_start, KTE=min(k_end,kde-1) &
- , num_tiles=grid%num_tiles, &
- u10=grid%u10, v10=grid%v10, th2=grid%th2, q2=grid%q2, &
- u10_ndg_old=grid%u10_ndg_old, &
- v10_ndg_old=grid%v10_ndg_old, &
- t2_ndg_old=grid%t2_ndg_old, &
- th2_ndg_old=grid%th2_ndg_old, &
- q2_ndg_old=grid%q2_ndg_old, &
- rh_ndg_old=grid%rh_ndg_old, &
- psl_ndg_old=grid%psl_ndg_old, &
- ps_ndg_old=grid%ps_ndg_old, &
- tob_ndg_old=grid%tob_ndg_old, &
- odis_ndg_old=grid%odis_ndg_old, &
- u10_ndg_new=grid%u10_ndg_new, &
- v10_ndg_new=grid%v10_ndg_new, &
- t2_ndg_new=grid%t2_ndg_new, &
- th2_ndg_new=grid%th2_ndg_new, &
- q2_ndg_new=grid%q2_ndg_new, &
- rh_ndg_new=grid%rh_ndg_new, &
- psl_ndg_new=grid%psl_ndg_new, &
- ps_ndg_new=grid%ps_ndg_new, &
- tob_ndg_new=grid%tob_ndg_new, &
- odis_ndg_new=grid%odis_ndg_new &
- ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe &
- ,IMSX=imsx,IMEX=imex,JMSX=jmsx,JMEX=jmex,KMSX=kmsx,KMEX=kmex &
- ,IPSX=ipsx,IPEX=ipex,JPSX=jpsx,JPEX=jpex,KPSX=kpsx,KPEX=kpex &
- ,IMSY=imsy,IMEY=imey,JMSY=jmsy,JMEY=jmey,KMSY=kmsy,KMEY=kmey &
- ,IPSY=ipsy,IPEY=ipey,JPSY=jpsy,JPEY=jpey,KPSY=kpsy,KPEY=kpey )
-
-BENCH_END(fdda_driver_tim)
-
- END SUBROUTINE first_rk_step_part1
-
-END MODULE module_first_rk_step_part1
diff --git a/UTIL/wrfcmaq_twoway_coupler/dyn_em/solve_em.F b/UTIL/wrfcmaq_twoway_coupler/dyn_em/solve_em.F
deleted file mode 100644
index f31937f67a..0000000000
--- a/UTIL/wrfcmaq_twoway_coupler/dyn_em/solve_em.F
+++ /dev/null
@@ -1,4909 +0,0 @@
-!WRF:MEDIATION_LAYER:SOLVER
-
-SUBROUTINE solve_em ( grid , config_flags &
-! Arguments generated from Registry
-#include "dummy_new_args.inc"
-!
- )
-! Driver layer modules
- USE module_state_description
- USE module_domain, ONLY : &
- domain, get_ijk_from_grid, get_ijk_from_subgrid &
- ,domain_get_current_time, domain_get_start_time &
- ,domain_get_sim_start_time, domain_clock_get,is_alarm_tstep
- USE module_domain_type, ONLY : history_alarm, restart_alarm, auxinput4_alarm &
- ,boundary_alarm
- USE module_configure, ONLY : grid_config_rec_type
- USE module_driver_constants
- USE module_machine
- USE module_tiles, ONLY : set_tiles
-#ifdef DM_PARALLEL
- USE module_dm, ONLY : &
- local_communicator, mytask, ntasks, ntasks_x, ntasks_y &
- ,local_communicator_periodic, wrf_dm_maxval
- USE module_comm_dm, ONLY : &
- halo_em_a_sub,halo_em_b_sub,halo_em_c2_sub,halo_em_chem_e_3_sub &
- ,halo_em_chem_e_5_sub,halo_em_chem_e_7_sub,halo_em_chem_old_e_5_sub &
- ,halo_em_chem_old_e_7_sub,halo_em_c_sub,halo_em_d2_3_sub &
- ,halo_em_d2_5_sub,halo_em_d3_3_sub,halo_em_d3_5_sub,halo_em_d_sub &
- ,halo_em_e_3_sub,halo_em_e_5_sub,halo_em_hydro_uv_sub &
- ,halo_em_moist_e_3_sub,halo_em_moist_e_5_sub,halo_em_moist_e_7_sub &
- ,halo_em_moist_old_e_5_sub,halo_em_moist_old_e_7_sub &
- ,halo_em_scalar_e_3_sub,halo_em_scalar_e_5_sub,halo_em_scalar_e_7_sub &
- ,halo_em_scalar_old_e_5_sub,halo_em_scalar_old_e_7_sub,halo_em_tke_3_sub &
- ,halo_em_tke_5_sub,halo_em_tke_7_sub,halo_em_tke_advect_3_sub &
- ,halo_em_tke_advect_5_sub,halo_em_tke_old_e_5_sub &
- ,halo_em_tke_old_e_7_sub,halo_em_tracer_e_3_sub,halo_em_tracer_e_5_sub &
- ,halo_em_tracer_e_7_sub,halo_em_tracer_old_e_5_sub &
- ,halo_em_tracer_old_e_7_sub,halo_em_sbm_sub,period_bdy_em_a_sub &
- ,period_bdy_em_b3_sub,period_bdy_em_b_sub,period_bdy_em_chem2_sub &
- ,period_bdy_em_chem_old_sub,period_bdy_em_chem_sub,period_bdy_em_d3_sub &
- ,period_bdy_em_d_sub,period_bdy_em_e_sub,period_bdy_em_moist2_sub &
- ,period_bdy_em_moist_old_sub,period_bdy_em_moist_sub &
- ,period_bdy_em_scalar2_sub,period_bdy_em_scalar_old_sub &
- ,period_bdy_em_scalar_sub,period_bdy_em_tke_old_sub, period_bdy_em_tke_sub &
- ,period_bdy_em_tracer2_sub,period_bdy_em_tracer_old_sub &
- ,period_bdy_em_tracer_sub,period_em_da_sub,period_em_hydro_uv_sub &
- ,period_em_f_sub,period_em_g_sub &
- ,halo_em_f_1_sub,halo_em_init_4_sub,halo_em_thetam_sub,period_em_thetam_sub &
- ,halo_em_d_pv_sub
-#endif
- USE module_utility
-! Mediation layer modules
-! Model layer modules
- USE module_model_constants
- USE module_small_step_em
- USE module_em
- USE module_big_step_utilities_em
- USE module_bc
- USE module_bc_em
- USE module_solvedebug_em
- USE module_physics_addtendc
- USE module_diffusion_em
- USE module_polarfft
- USE module_microphysics_driver
- USE module_microphysics_zero_out
-! USE module_lightning_driver, ONLY : lightning_driver
- USE module_fddaobs_driver
-! USE module_diagnostics
-#if (WRF_CHEM == 1)
- USE module_input_chem_data
- USE module_input_tracer
- USE module_chem_utilities
-#endif
- USE module_dust_emis
- USE module_first_rk_step_part1
- USE module_first_rk_step_part2
- USE module_after_all_rk_steps
- USE module_llxy, ONLY : proj_cassini
- USE module_avgflx_em, ONLY : zero_avgflx, upd_avgflx
- USE module_cpl, ONLY : coupler_on, cpl_settime, cpl_store_input
-#if (WRF_CMAQ == 1)
- use twoway_data_module
-#endif
-
- IMPLICIT NONE
-
- ! Input data.
-
- TYPE(domain) , TARGET :: grid
-
- ! Definitions of dummy arguments to this routine (generated from Registry).
-#include "dummy_new_decl.inc"
-
- ! Structure that contains run-time configuration (namelist) data for domain
- TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags
-
- ! Local data
-
- INTEGER :: k_start , k_end, its, ite, jts, jte
- INTEGER :: ids , ide , jds , jde , kds , kde , &
- ims , ime , jms , jme , kms , kme , &
- ips , ipe , jps , jpe , kps , kpe
-
- INTEGER :: sids , side , sjds , sjde , skds , skde , &
- sims , sime , sjms , sjme , skms , skme , &
- sips , sipe , sjps , sjpe , skps , skpe
-
-
- INTEGER :: imsx, imex, jmsx, jmex, kmsx, kmex, &
- ipsx, ipex, jpsx, jpex, kpsx, kpex, &
- imsy, imey, jmsy, jmey, kmsy, kmey, &
- ipsy, ipey, jpsy, jpey, kpsy, kpey
-
- INTEGER :: ij , iteration
- INTEGER :: im , num_3d_m , ic , num_3d_c , is , num_3d_s
- INTEGER :: loop
- INTEGER :: sz
- INTEGER :: iswater
-
- LOGICAL :: specified_bdy, channel_bdy
-
- REAL :: t_new, time_duration_of_lbcs
-
-! begin WRF-CMAQ twoway coupled model block
- integer :: twoway_jdate, & ! CMAQ current job date
- twoway_jtime, & ! CMAQ current job time
- met_file_tstep ! MCIP like MET file time step
-
- integer, save :: cmaq_nstep, & ! total number of CMAQ steps
- wrf_end_step, & ! WRF ending step #
- counter = -1, & ! step counter
- wrf_cmaq_freq, & ! call frequency between WRF and CMAQ
- wrf_cmaq_option ! WRF-CMAQ coupled model option
- ! 0 = run WRF only
- ! 1 = run WRF only w producing MCIP like GRID and MET files
- ! 2 = run WRF-CMAQ coupled model w/o producing MCIP like GRID and MET files
- ! 3 = run WRF-CMAQ coupled model w producing MCIP like GRID and MET files
-
- logical :: cmaq_step ! CMAQ step number
-
- logical, save :: firstime = .true., & ! logical variable indicating first time
- feedback_is_ready, & ! logical variable indicating feedback process can proceed
- feedback_restart, & ! logical variable indicating feedback information is available
- direct_sw_feedback ! logical variable indicating direct aerosol sw feedback is on or not
-! end WRF-CMAQ twoway coupled model block
-
- ! Changes in tendency at this timestep
- real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33) :: h_tendency, &
- z_tendency
-
- ! Whether advection should produce decoupled horizontal and vertical advective tendency outputs
- LOGICAL :: tenddec
-
- ! Flag for producing diagnostic fields (e.g., radar reflectivity)
- LOGICAL :: diag_flag
- INTEGER :: ke_diag ! tells reflectivity calculation whether to do full depth or only k=1
- LOGICAL :: restart_flag ! tells if it is a restart timestep to write restart files.
-
-#if (WRF_CHEM == 1)
- ! Index cross-referencing array for tendency accumulation
- INTEGER, DIMENSION( num_chem ) :: adv_ct_indices
-#endif
-
-! storage for tendencies and decoupled state (generated from Registry)
-
-#include "i1_decl.inc"
-! Previous time level of tracer arrays now defined as i1 variables;
-! the state 4d arrays now redefined as 1-time level arrays in Registry.
-! Benefit: save memory in nested runs, since only 1 domain is active at a
-! time. Potential problem on stack-limited architectures: increases
-! amount of data on program stack by making these automatic arrays.
-
- INTEGER :: rc
- INTEGER :: number_of_small_timesteps, rk_step
- INTEGER :: klevel,ijm,ijp,i,j,k,size1,size2 ! for prints/plots only
- INTEGER :: idum1, idum2, dynamics_option
-
- INTEGER :: rk_order, iwmax, jwmax, kwmax
- REAL :: dt_rk, dts_rk, dts, dtm, wmax
- REAL , ALLOCATABLE , DIMENSION(:) :: max_vert_cfl_tmp, max_horiz_cfl_tmp
- LOGICAL :: leapfrog
- INTEGER :: l,kte,kk
- LOGICAL :: f_flux ! flag for computing averaged fluxes in cu_gd
- REAL :: curr_secs, curr_secs2
- INTEGER :: num_sound_steps
- INTEGER :: idex, jdex
- REAL :: max_msft
- REAL :: spacing
-
- INTEGER :: ii, jj !kk is above after l,kte
- REAL :: dclat
- INTEGER :: debug_level
-
-! urban related variables
- INTEGER :: NUM_ROOF_LAYERS, NUM_WALL_LAYERS, NUM_ROAD_LAYERS ! urban
-
- TYPE(WRFU_TimeInterval) :: tmpTimeInterval, tmpTimeInterval2
- REAL :: real_time
- LOGICAL :: adapt_step_flag
- LOGICAL :: fill_w_flag
-
-! variables for flux-averaging code 20091223
- CHARACTER*256 :: message, message2, message3
- REAL :: old_dt
- TYPE(WRFU_Time) :: temp_time, CurrTime, restart_time
- INTEGER, PARAMETER :: precision = 100
- INTEGER :: num, den
- TYPE(WRFU_TimeInterval) :: dtInterval, intervaltime,restartinterval
-
-#if (WRF_CMAQ == 1)
- interface
- SUBROUTINE CMAQ_DRIVER ( MODEL_STDATE, MODEL_STTIME, MODEL_TSTEP, &
- MODEL_JDATE, MODEL_JTIME, LAST_STEP, &
- COUPLE_TSTEP, NCOLS_IN, NLAYS_IN)
- INTEGER, INTENT( IN ) :: MODEL_STDATE, MODEL_STTIME, MODEL_TSTEP
- INTEGER, INTENT( OUT ) :: MODEL_JDATE, MODEL_JTIME
- LOGICAL, INTENT( IN ) :: LAST_STEP
- INTEGER, INTENT( IN ), OPTIONAL :: COUPLE_TSTEP
- INTEGER, INTENT( IN ), OPTIONAL :: NCOLS_IN, NLAYS_IN
- END SUBROUTINE CMAQ_DRIVER
- end interface
-#endif
-
-! Define benchmarking timers if -DBENCH is compiled
-#include "bench_solve_em_def.h"
-
-!----------------------
-! Executable statements
-!----------------------
-
-!
-!
-! solve_em is the main driver for advancing a grid a single timestep.
-! It is a mediation-layer routine -> DM and SM calls are made where
-! needed for parallel processing.
-!
-! solve_em can integrate the equations using 3 time-integration methods
-!
-! - 3rd order Runge-Kutta time integration (recommended)
-!
-! - 2nd order Runge-Kutta time integration
-!
-! The main sections of solve_em are
-!
-! (1) Runge-Kutta (RK) loop
-!
-! (2) Non-timesplit physics (i.e., tendencies computed for updating
-! model state variables during the first RK sub-step (loop)
-!
-! (3) Small (acoustic, sound) timestep loop - within the RK sub-steps
-!
-! (4) scalar advance for moist and chem scalar variables (and TKE)
-! within the RK sub-steps.
-!
-! (5) time-split physics (after the RK step), currently this includes
-! only microphyics
-!
-! A more detailed description of these sections follows.
-!
-!
-
-! Initialize timers if compiled with -DBENCH
-#include "bench_solve_em_init.h"
-
-#if (WRF_CMAQ == 1)
- if (firstime) then
- CALL nl_get_feedback_restart ( .false., feedback_restart )
- if (feedback_restart) then
- feedback_is_ready = .true.
- else
- feedback_is_ready = .false.
- end if
- end if
-#else
- feedback_is_ready = .false.
-#endif
-
-! set runge-kutta solver (2nd or 3rd order)
-
- dynamics_option = config_flags%rk_ord
-
-! Obtain dimension information stored in the grid data structure.
-
- CALL get_ijk_from_grid ( grid , &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- imsx, imex, jmsx, jmex, kmsx, kmex, &
- ipsx, ipex, jpsx, jpex, kpsx, kpex, &
- imsy, imey, jmsy, jmey, kmsy, kmey, &
- ipsy, ipey, jpsy, jpey, kpsy, kpey )
-
- CALL get_ijk_from_subgrid ( grid , &
- sids, side, sjds, sjde, skds, skde, &
- sims, sime, sjms, sjme, skms, skme, &
- sips, sipe, sjps, sjpe, skps, skpe )
- k_start = kps
- k_end = kpe
-
- num_3d_m = num_moist
- num_3d_c = num_chem
- num_3d_s = num_scalar
-
-! backward integration needs to advect only QV
- if (grid%dfi_stage .EQ. DFI_BCK) then
- num_3d_m = P_QV
- num_3d_s = PARAM_FIRST_SCALAR - 1
- endif
-
- f_flux = config_flags%do_avgflx_cugd .EQ. 1
-
-! Compute these starting and stopping locations for each tile and number of tiles.
-! See: https://www2.mmm.ucar.edu/wrf/WG2/topics/settiles
- CALL set_tiles ( ZONE_SOLVE_EM, grid , ids , ide , jds , jde , ips , ipe , jps , jpe )
-! CALL set_tiles ( grid , ids , ide , jds , jde , ips , ipe , jps , jpe )
-
-! Max values of CFL for adaptive time step scheme
-
- ALLOCATE (max_vert_cfl_tmp(grid%num_tiles))
- ALLOCATE (max_horiz_cfl_tmp(grid%num_tiles))
-
- !
- ! Calculate current time in seconds since beginning of model run.
- ! Unfortunately, ESMF does not seem to have a way to return
- ! floating point seconds based on a TimeInterval. So, we will
- ! calculate it here--but, this is not clean!!
- !
- tmpTimeInterval = domain_get_current_time ( grid ) - domain_get_sim_start_time ( grid )
- tmpTimeInterval2 = domain_get_current_time ( grid ) - domain_get_start_time ( grid )
- curr_secs = real_time(tmpTimeInterval)
- curr_secs2 = real_time(tmpTimeInterval2)
-
- old_dt = grid%dt ! store old time step for flux averaging code at end of RK loop
-
-!-----------------------------------------------------------------------------
-! Adaptive time step: Added by T. Hutchinson, WSI 3/5/07
-! In this call, we do the time-step adaptation and set time-dependent lateral
-! boundary condition nudging weights.
-!
- IF ( (config_flags%use_adaptive_time_step) .and. &
- ( (.not. grid%nested) .or. &
- ( (grid%nested) .and. (abs(grid%dtbc) < 0.0001) ) ) )THEN
- CALL adapt_timestep(grid, config_flags)
- adapt_step_flag = .TRUE.
- ELSE
- adapt_step_flag = .FALSE.
- ENDIF
-! End of adaptive time step modifications
-!-----------------------------------------------------------------------------
-!
-! Set restart flag value history output time
-!-----------------------------------------------------------------------------
- restart_flag = .false.
- if ( Is_alarm_tstep(grid%domain_clock, grid%alarms(restart_alarm)) ) then
- restart_flag = .true.
- endif
-!
-! Set diagnostic flag value history output time
-!-----------------------------------------------------------------------------
-
- ke_diag = kms ! default to ke_diag=1 in case of nwp_diagnostics == 1
- diag_flag = .false.
- if ( Is_alarm_tstep(grid%domain_clock, grid%alarms(HISTORY_ALARM)) ) then
- diag_flag = .true.
- ke_diag = min(k_end,kde-1) ! set depth to full domain for reflectivity field
- endif
- IF (config_flags%nwp_diagnostics == 1) diag_flag = .true.
-
- grid%itimestep = grid%itimestep + 1
- grid%dtbc = grid%dtbc + grid%dt
-
- IF( coupler_on ) CALL cpl_store_input( grid, config_flags )
-
- IF (config_flags%polar) dclat = 90./REAL(jde-jds) !(0.5 * 180/ny)
-
-#if (WRF_CHEM == 1)
-
- kte=min(k_end,kde-1)
-# ifdef DM_PARALLEL
- if ( num_chem >= PARAM_FIRST_SCALAR ) then
-!-----------------------------------------------------------------------
-! see matching halo calls below for stencils
-!--------------------------------------------------------------
- CALL wrf_debug ( 200 , ' call HALO_RK_CHEM' )
- IF ( config_flags%h_sca_adv_order <= 4 ) THEN
-# include "HALO_EM_CHEM_E_3.inc"
- IF( config_flags%progn > 0 ) THEN
-# include "HALO_EM_SCALAR_E_3.inc"
- ENDIF
- IF( config_flags%cu_physics == CAMZMSCHEME ) THEN
-# include "HALO_EM_SCALAR_E_3.inc"
- ENDIF
- ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
-# include "HALO_EM_CHEM_E_5.inc"
- IF( config_flags%cu_physics == CAMZMSCHEME ) THEN
-# include "HALO_EM_SCALAR_E_5.inc"
- ENDIF
- IF( config_flags%progn > 0 ) THEN
-# include "HALO_EM_SCALAR_E_5.inc"
- ENDIF
- ELSE
- WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
- CALL wrf_error_fatal(TRIM(wrf_err_message))
- ENDIF
- ENDIF
- if ( num_tracer >= PARAM_FIRST_SCALAR ) then
-!-----------------------------------------------------------------------
-! see matching halo calls below for stencils
-!--------------------------------------------------------------
- CALL wrf_debug ( 200 , ' call HALO_RK_tracer' )
- IF ( config_flags%h_sca_adv_order <= 4 ) THEN
-# include "HALO_EM_TRACER_E_3.inc"
- ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
-# include "HALO_EM_TRACER_E_5.inc"
- ELSE
- WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
- CALL wrf_error_fatal(TRIM(wrf_err_message))
- ENDIF
- ENDIF
-# endif
-!--------------------------------------------------------------
- adv_ct_indices( : ) = 1
- IF ( config_flags%chemdiag == USECHEMDIAG ) THEN
- ! modify tendency list here
- ! note that the referencing direction here is opposite of that in chem_driver
- adv_ct_indices(p_co ) = p_advh_co
- adv_ct_indices(p_o3 ) = p_advh_o3
- adv_ct_indices(p_no ) = p_advh_no
- adv_ct_indices(p_no2 ) = p_advh_no2
- adv_ct_indices(p_hno3) = p_advh_hno3
- adv_ct_indices(p_iso ) = p_advh_iso
- adv_ct_indices(p_ho ) = p_advh_ho
- adv_ct_indices(p_ho2 ) = p_advh_ho2
- END IF
-#endif
-
- rk_order = config_flags%rk_ord
-
- IF ( grid%time_step_sound == 0 ) THEN
-! This function will give 4 for 6*dx and 6 for 10*dx and returns even numbers only
- spacing = min(grid%dx, grid%dy)
- IF ( ( config_flags%use_adaptive_time_step ) .AND. ( config_flags%map_proj == PROJ_CASSINI ) ) THEN
- max_msft=MIN ( MAX(grid%max_msftx, grid%max_msfty) , &
- 1.0/COS(config_flags%fft_filter_lat*degrad) )
- num_sound_steps = max ( 2 * ( INT (300. * grid%dt / (spacing / max_msft) - 0.01 ) + 1 ), 4 )
- ELSE IF ( config_flags%use_adaptive_time_step ) THEN
- max_msft= MAX(grid%max_msftx, grid%max_msfty)
- num_sound_steps = max ( 2 * ( INT (300. * grid%dt / (spacing / max_msft) - 0.01 ) + 1 ), 4 )
- ELSE
- num_sound_steps = max ( 2 * ( INT (300. * grid%dt / spacing - 0.01 ) + 1 ), 4 )
- END IF
- WRITE(wrf_err_message,*)'grid spacing, dt, time_step_sound=',spacing,grid%dt,num_sound_steps
- CALL wrf_debug ( 50 , wrf_err_message )
- ELSE
- num_sound_steps = grid%time_step_sound
- ENDIF
-
- dts = grid%dt/float(num_sound_steps)
-
- IF (config_flags%use_adaptive_time_step) THEN
-
- CALL get_wrf_debug_level( debug_level )
- IF ((config_flags%time_step < 0) .AND. (debug_level.GE.50)) THEN
-#ifdef DM_PARALLEL
- CALL wrf_dm_maxval(grid%max_vert_cfl, idex, jdex)
-#endif
- WRITE(wrf_err_message,*)'variable dt, max horiz cfl, max vert cfl: ',&
- grid%dt, grid%max_horiz_cfl, grid%max_vert_cfl
- CALL wrf_debug ( 0 , wrf_err_message )
- ENDIF
-
- grid%max_cfl_val = 0
- grid%max_horiz_cfl = 0
- grid%max_vert_cfl = 0
- ENDIF
-
-! setting bdy tendencies to zero for DFI if constant_bc = true
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
-
-! IF( config_flags%specified .AND. grid%dfi_opt .NE. DFI_NODFI &
-! .AND. config_flags%constant_bc .AND. (grid%dfi_stage .EQ. DFI_BCK .OR. grid%dfi_stage .EQ. DFI_FWD) ) THEN
- IF( config_flags%specified .AND. config_flags%constant_bc ) THEN
-
- CALL zero_bdytend (grid%u_btxs,grid%u_btxe,grid%u_btys,grid%u_btye, &
- grid%v_btxs,grid%v_btxe,grid%v_btys,grid%v_btye, &
- grid%ph_btxs,grid%ph_btxe,grid%ph_btys,grid%ph_btye, &
- grid%t_btxs,grid%t_btxe,grid%t_btys,grid%t_btye, &
- grid%w_btxs,grid%w_btxe,grid%w_btys,grid%w_btye, &
- grid%mu_btxs,grid%mu_btxe,grid%mu_btys,grid%mu_btye, &
- moist_btxs,moist_btxe, &
- moist_btys,moist_btye, &
- scalar_btxs,scalar_btxe, &
- scalar_btys,scalar_btye, &
- grid%spec_bdy_width,num_3d_m,num_3d_s, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- ips,ipe, jps,jpe, kps,kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
-
- ENDIF
-
- ! If the user has requested to optionally select the moist theta (use_theta_m==1)
- ! switch, the first setting of the "old" value of theta_m uses the "old"
- ! value of Qv. The moist_old variable does not exist until after the advection
- ! towards the end of the RK loop. For the first time in the RK loop, we need
- ! a reasonable value for moist_old.
-
- CALL initialize_moist_old ( moist_old(:,:,:,P_Qv), &
- moist(:,:,:,P_Qv) , &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
- ENDDO
- !$OMP END PARALLEL DO
-
- ! Now that we have initialized the moist_old values with P_Qv for
- ! computing a moist t_tendf after rk_step part2, fill in the halo
- ! and period boundaries.
-
-#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
-# include "HALO_EM_MOIST_OLD_E_7.inc"
-# include "PERIOD_BDY_EM_MOIST_OLD.inc"
-#endif
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
- im = P_Qv
- CALL set_physical_bc3d( moist_old(ims,kms,jms,im), 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- END DO
- !$OMP END PARALLEL DO
-
-!**********************************************************************
-!
-! LET US BEGIN.......
-!
-!
-!
-! (1) RK integration loop is named the "Runge_Kutta_loop:"
-!
-! Predictor-corrector type time integration.
-! Advection terms are evaluated at time t for the predictor step,
-! and advection is re-evaluated with the latest predicted value for
-! each succeeding time corrector step
-!
-! 2nd order Runge Kutta (rk_order = 2):
-! Step 1 is taken to the midpoint predictor, step 2 is the full step.
-!
-! 3rd order Runge Kutta (rk_order = 3):
-! Step 1 is taken to from t to dt/3, step 2 is from t to dt/2,
-! and step 3 is from t to dt.
-!
-! non-timesplit physics are evaluated during first RK step and
-! these physics tendencies are stored for use in each RK pass.
-!
-!
-!**********************************************************************
-
- Runge_Kutta_loop: DO rk_step = 1, rk_order
-
- ! Set the step size and number of small timesteps for
- ! each part of the timestep
-
- dtm = grid%dt
- IF ( rk_order == 1 ) THEN
-
- write(wrf_err_message,*)' leapfrog removed, error exit for dynamics_option = ',dynamics_option
- CALL wrf_error_fatal( wrf_err_message )
-
- ELSE IF ( rk_order == 2 ) THEN ! 2nd order Runge-Kutta timestep
-
- IF ( rk_step == 1) THEN
- dt_rk = 0.5*grid%dt
- dts_rk = dts
- number_of_small_timesteps = num_sound_steps/2
- ELSE
- dt_rk = grid%dt
- dts_rk = dts
- number_of_small_timesteps = num_sound_steps
- ENDIF
-
- ELSE IF ( rk_order == 3 ) THEN ! third order Runge-Kutta
-
- IF ( rk_step == 1) THEN
- dt_rk = grid%dt/3.
- dts_rk = dt_rk
- number_of_small_timesteps = 1
- ELSE IF (rk_step == 2) THEN
- dt_rk = 0.5*grid%dt
- dts_rk = dts
- number_of_small_timesteps = num_sound_steps/2
- ELSE
- dt_rk = grid%dt
- dts_rk = dts
- number_of_small_timesteps = num_sound_steps
- ENDIF
-
- ELSE
-
- write(wrf_err_message,*)' unknown solver, error exit for dynamics_option = ',dynamics_option
- CALL wrf_error_fatal( wrf_err_message )
-
- END IF
-
-! Ensure that polar meridional velocity is zero
- IF (config_flags%polar) THEN
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
- CALL zero_pole ( grid%v_1, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
- CALL zero_pole ( grid%v_2, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
- END DO
- !$OMP END PARALLEL DO
- END IF
-!
-! Time level t is in the *_2 variable in the first part
-! of the step, and in the *_1 variable after the predictor.
-! the latest predicted values are stored in the *_2 variables.
-!
- CALL wrf_debug ( 200 , ' call rk_step_prep ' )
-
-BENCH_START(step_prep_tim)
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
-
- DO ij = 1 , grid%num_tiles
-
- CALL rk_step_prep ( config_flags, rk_step, &
- grid%u_2, grid%v_2, grid%w_2, grid%t_2, grid%ph_2, grid%mu_2, &
- grid%c1h, grid%c2h, grid%c1f, grid%c2f, moist, &
- grid%ru, grid%rv, grid%rw, grid%ww, grid%php, grid%alt, grid%muu, grid%muv, &
- grid%mub, grid%mut, grid%phb, grid%pb, grid%p, grid%al, grid%alb, &
- cqu, cqv, cqw, &
- grid%msfux, grid%msfuy, grid%msfvx, grid%msfvx_inv, &
- grid%msfvy, grid%msftx, grid%msfty, &
- grid%fnm, grid%fnp, grid%dnw, grid%rdx, grid%rdy, &
- num_3d_m, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
-
- END DO
- !$OMP END PARALLEL DO
-BENCH_END(step_prep_tim)
-
-#ifdef DM_PARALLEL
-!-----------------------------------------------------------------------
-! Stencils for patch communications (WCS, 29 June 2001)
-! Note: the small size of this halo exchange reflects the
-! fact that we are carrying the uncoupled variables
-! as state variables in the mass coordinate model, as
-! opposed to the coupled variables as in the height
-! coordinate model.
-!
-! * * * * *
-! * * * * * * * * *
-! * + * * + * * * + * *
-! * * * * * * * * *
-! * * * * *
-!
-! 3D variables - note staggering! ru(X), rv(Y), ww(Z), php(Z)
-!
-! ru x
-! rv x
-! ww x
-! php x
-! alt x
-! ph_2 x
-! phb x
-!
-! the following are 2D (xy) variables
-!
-! muu x
-! muv x
-! mut x
-!--------------------------------------------------------------
-# include "HALO_EM_A.inc"
-#endif
-
-! set boundary conditions on variables
-! from big_step_prep for use in big_step_proc
-
-#ifdef DM_PARALLEL
-# include "PERIOD_BDY_EM_A.inc"
-#endif
-
-BENCH_START(set_phys_bc_tim)
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij, ii, jj, kk )
-
- DO ij = 1 , grid%num_tiles
-
- CALL wrf_debug ( 200 , ' call rk_phys_bc_dry_1' )
-
- CALL rk_phys_bc_dry_1( config_flags, grid%ru, grid%rv, grid%rw, grid%ww, &
- grid%muu, grid%muv, grid%mut, grid%php, grid%alt, grid%p, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
- CALL set_physical_bc3d( grid%rho, 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- CALL set_physical_bc3d( grid%al, 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- CALL set_physical_bc3d( grid%ph_2, 'w', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
-
- IF (config_flags%polar) THEN
-
-!-------------------------------------------------------
-! lat-lon grid pole-point (v) specification (extrapolate v, rv to the pole)
-!-------------------------------------------------------
-
- CALL pole_point_bc ( grid%v_1, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
-
- CALL pole_point_bc ( grid%v_2, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
-
-!-------------------------------------------------------
-! end lat-lon grid pole-point (v) specification
-!-------------------------------------------------------
-
- ENDIF
- END DO
- !$OMP END PARALLEL DO
-BENCH_END(set_phys_bc_tim)
-
- rk_step_is_one : IF (rk_step == 1) THEN ! only need to initialize diffusion tendencies
-
-BENCH_START(calc_p_rho_tim)
-
-!
-!
-!(2) The non-timesplit physics begins with a call to "phy_prep"
-! (which computes some diagnostic variables such as temperature,
-! pressure, u and v at p points, etc). This is followed by
-! calls to the physics drivers:
-!
-! radiation,
-! surface,
-! pbl,
-! cumulus,
-! fddagd,
-! 3D TKE and mixing.
-!
-!
-
- IF (coupler_on) CALL cpl_settime( curr_secs2 )
-
- CALL first_rk_step_part1 ( grid, config_flags &
- , moist , moist_tend &
- , chem , chem_tend &
- , tracer, tracer_tend &
- , scalar , scalar_tend &
- , fdda3d, fdda2d &
- , aerod &
- , ru_tendf, rv_tendf &
- , rw_tendf, t_tendf &
- , ph_tendf, mu_tendf &
- , tke_tend &
- , config_flags%use_adaptive_time_step &
- , curr_secs &
- , psim , psih , gz1oz0 &
- , chklowq &
- , cu_act_flag , hol , th_phy &
- , pi_phy , p_phy , grid%t_phy &
- , dz8w , p8w , t8w &
- , ids, ide, jds, jde, kds, kde &
- , ims, ime, jms, jme, kms, kme &
- , ips, ipe, jps, jpe, kps, kpe &
- , imsx, imex, jmsx, jmex, kmsx, kmex &
- , ipsx, ipex, jpsx, jpex, kpsx, kpex &
- , imsy, imey, jmsy, jmey, kmsy, kmey &
- , ipsy, ipey, jpsy, jpey, kpsy, kpey &
- , k_start , k_end &
- , f_flux &
- , aerocu &
- , restart_flag &
- , feedback_is_ready=feedback_is_ready &
- )
-
-#ifdef DM_PARALLEL
- IF ( config_flags%bl_pbl_physics == MYNNPBLSCHEME2 .OR. &
- config_flags%bl_pbl_physics == MYNNPBLSCHEME3 ) THEN
-# include "HALO_EM_SCALAR_E_5.inc"
- ENDIF
-#endif
-
- CALL first_rk_step_part2 ( grid, config_flags &
- , moist , moist_old , moist_tend &
- , chem , chem_tend &
- , tracer, tracer_tend &
- , scalar , scalar_tend &
- , fdda3d, fdda2d &
- , ru_tendf, rv_tendf &
- , rw_tendf, t_tendf &
- , ph_tendf, mu_tendf &
- , tke_tend &
- , adapt_step_flag , curr_secs &
- , psim , psih , gz1oz0 &
- , chklowq &
- , cu_act_flag , hol , th_phy &
- , pi_phy , p_phy , grid%t_phy &
- , dz8w , p8w , t8w &
- , nba_mij, num_nba_mij & !JDM
- , nba_rij, num_nba_rij & !JDM
- , ids, ide, jds, jde, kds, kde &
- , ims, ime, jms, jme, kms, kme &
- , ips, ipe, jps, jpe, kps, kpe &
- , imsx, imex, jmsx, jmex, kmsx, kmex &
- , ipsx, ipex, jpsx, jpex, kpsx, kpex &
- , imsy, imey, jmsy, jmey, kmsy, kmey &
- , ipsy, ipey, jpsy, jpey, kpsy, kpey &
- , k_start , k_end &
- )
-
- END IF rk_step_is_one
-
-BENCH_START(rk_tend_tim)
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
-
- CALL wrf_debug ( 200 , ' call rk_tendency' )
- CALL rk_tendency ( config_flags, rk_step &
- ,grid%ru_tend, grid%rv_tend, rw_tend, ph_tend, t_tend &
- ,ru_tendf, rv_tendf, rw_tendf, ph_tendf, t_tendf &
- ,mu_tend, grid%u_save, grid%v_save, w_save, ph_save &
- ,grid%t_save, mu_save, grid%rthften &
- ,grid%ru, grid%rv, grid%rw, grid%ww, wwE, wwI &
- ,grid%u_2, grid%v_2, grid%w_2, grid%t_2, grid%ph_2 &
- ,grid%u_1, grid%v_1, grid%w_1, grid%t_1, grid%ph_1 &
- ,grid%h_diabatic, grid%phb, grid%t_init &
- ,grid%mu_1, grid%mu_2, grid%mut, grid%muu, grid%muv, grid%mub &
- ,grid%c1h, grid%c2h, grid%c1f, grid%c2f &
- ,grid%al, grid%ht, grid%alt, grid%p, grid%pb, grid%php, cqu, cqv, cqw &
- ,grid%u_base, grid%v_base, grid%t_base, grid%qv_base, grid%z_base &
- ,grid%msfux,grid%msfuy, grid%msfvx, grid%msfvx_inv &
- ,grid%msfvy, grid%msftx,grid%msfty, grid%clat, grid%f, grid%e, grid%sina, grid%cosa &
- ,grid%fnm, grid%fnp, grid%rdn, grid%rdnw &
- ,grid%dt, grid%rdx, grid%rdy, grid%khdif, grid%kvdif, grid%xkmh, grid%xkhh &
- ,grid%diff_6th_opt, grid%diff_6th_factor &
- ,config_flags%momentum_adv_opt &
- ,grid%dampcoef,grid%zdamp,config_flags%damp_opt,config_flags%rad_nudge &
- ,grid%cf1, grid%cf2, grid%cf3, grid%cfn, grid%cfn1, num_3d_m &
- ,config_flags%non_hydrostatic, config_flags%top_lid &
- ,grid%u_frame, grid%v_frame &
- ,ids, ide, jds, jde, kds, kde &
- ,ims, ime, jms, jme, kms, kme &
- ,grid%i_start(ij), grid%i_end(ij) &
- ,grid%j_start(ij), grid%j_end(ij) &
- ,k_start, k_end &
- ,max_vert_cfl_tmp(ij), max_horiz_cfl_tmp(ij) )
- END DO
- !$OMP END PARALLEL DO
-BENCH_END(rk_tend_tim)
-
- IF (config_flags%use_adaptive_time_step) THEN
- DO ij = 1 , grid%num_tiles
- IF (max_horiz_cfl_tmp(ij) .GT. grid%max_horiz_cfl) THEN
- grid%max_horiz_cfl = max_horiz_cfl_tmp(ij)
- ENDIF
- IF (max_vert_cfl_tmp(ij) .GT. grid%max_vert_cfl) THEN
- grid%max_vert_cfl = max_vert_cfl_tmp(ij)
- ENDIF
- END DO
-
- IF (grid%max_horiz_cfl .GT. grid%max_cfl_val) THEN
- grid%max_cfl_val = grid%max_horiz_cfl
- ENDIF
- IF (grid%max_vert_cfl .GT. grid%max_cfl_val) THEN
- grid%max_cfl_val = grid%max_vert_cfl
- ENDIF
- ENDIF
-
-BENCH_START(relax_bdy_dry_tim)
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
-
- IF ( (config_flags%specified .or. config_flags%nested) .and. ( rk_step == 1 ) ) THEN
-
- CALL relax_bdy_dry ( config_flags, &
- grid%u_save, grid%v_save, ph_save, grid%t_save, &
- w_save, mu_tend, grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
- grid%ru, grid%rv, grid%ph_2, grid%t_2, &
- grid%w_2, grid%mu_2, grid%mut, &
- grid%u_bxs,grid%u_bxe,grid%u_bys,grid%u_bye, &
- grid%v_bxs,grid%v_bxe,grid%v_bys,grid%v_bye, &
- grid%ph_bxs,grid%ph_bxe,grid%ph_bys,grid%ph_bye, &
- grid%t_bxs,grid%t_bxe,grid%t_bys,grid%t_bye, &
- grid%w_bxs,grid%w_bxe,grid%w_bys,grid%w_bye, &
- grid%mu_bxs,grid%mu_bxe,grid%mu_bys,grid%mu_bye, &
- grid%u_btxs,grid%u_btxe,grid%u_btys,grid%u_btye, &
- grid%v_btxs,grid%v_btxe,grid%v_btys,grid%v_btye, &
- grid%ph_btxs,grid%ph_btxe,grid%ph_btys,grid%ph_btye, &
- grid%t_btxs,grid%t_btxe,grid%t_btys,grid%t_btye, &
- grid%w_btxs,grid%w_btxe,grid%w_btys,grid%w_btye, &
- grid%mu_btxs,grid%mu_btxe,grid%mu_btys,grid%mu_btye, &
- config_flags%spec_bdy_width, grid%spec_zone, grid%relax_zone, &
- grid%dtbc, grid%fcx, grid%gcx, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- ips,ipe, jps,jpe, kps,kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
-
- ENDIF
-
- CALL rk_addtend_dry( grid%ru_tend, grid%rv_tend, rw_tend, ph_tend, t_tend, &
- ru_tendf, rv_tendf, rw_tendf, ph_tendf, t_tendf, &
- grid%u_save, grid%v_save, w_save, ph_save, grid%t_save, &
- mu_tend, mu_tendf, rk_step, &
- grid%c1h, grid%c2h, &
- grid%h_diabatic, grid%mut, grid%msftx, &
- grid%msfty, grid%msfux,grid%msfuy, &
- grid%msfvx, grid%msfvx_inv, grid%msfvy, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- ips,ipe, jps,jpe, kps,kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
-
- IF( config_flags%specified .or. config_flags%nested ) THEN
- CALL spec_bdy_dry ( config_flags, &
- grid%ru_tend, grid%rv_tend, ph_tend, t_tend, &
- rw_tend, mu_tend, &
- grid%u_bxs,grid%u_bxe,grid%u_bys,grid%u_bye, &
- grid%v_bxs,grid%v_bxe,grid%v_bys,grid%v_bye, &
- grid%ph_bxs,grid%ph_bxe,grid%ph_bys,grid%ph_bye, &
- grid%t_bxs,grid%t_bxe,grid%t_bys,grid%t_bye, &
- grid%w_bxs,grid%w_bxe,grid%w_bys,grid%w_bye, &
- grid%mu_bxs,grid%mu_bxe,grid%mu_bys,grid%mu_bye, &
- grid%u_btxs,grid%u_btxe,grid%u_btys,grid%u_btye, &
- grid%v_btxs,grid%v_btxe,grid%v_btys,grid%v_btye, &
- grid%ph_btxs,grid%ph_btxe,grid%ph_btys,grid%ph_btye, &
- grid%t_btxs,grid%t_btxe,grid%t_btys,grid%t_btye, &
- grid%w_btxs,grid%w_btxe,grid%w_btys,grid%w_btye, &
- grid%mu_btxs,grid%mu_btxe,grid%mu_btys,grid%mu_btye, &
- config_flags%spec_bdy_width, grid%spec_zone, &
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- ips,ipe, jps,jpe, kps,kpe, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
-
-
- ENDIF
-
-!---------------------------------------------------------------------------------------------
-! KRS 9/12/2012: Inserted new IF block calls to spec_bdy_dry_perturb. If peturb_bdy=1, SKEBS
-! pattern passed in for perturbing the specified boundry conditions. If peturb_bdy=2, user
-! must provide pattern. mu_2, mub, msf* also passed in for coupling needed for tendecies.
-!---------------------------------------------------------------------------------------------
- IF( config_flags%specified .and. config_flags%perturb_bdy==1 ) THEN
- CALL spec_bdy_dry_perturb ( config_flags, &
- grid%ru_tend, grid%rv_tend, t_tend, &
- grid%mu_2, grid%mub, grid%c1h, grid%c2h, &
- grid%msfux, grid%msfvx, grid%msft, &
- grid%ru_tendf_stoch, grid%rv_tendf_stoch, grid%rt_tendf_stoch, &
- config_flags%spec_bdy_width, grid%spec_zone, &
- grid%num_stoch_levels, & ! stoch dims
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- ips,ipe, jps,jpe, kps,kpe, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
-
- ENDIF
-
- IF( config_flags%specified .and. config_flags%perturb_bdy==2 ) THEN
- CALL spec_bdy_dry_perturb ( config_flags, &
- grid%ru_tend, grid%rv_tend, t_tend, &
- grid%mu_2, grid%mub, grid%c1h, grid%c2h, &
- grid%msfux, grid%msfvx, grid%msft, &
- grid%field_u_tend_perturb, grid%field_v_tend_perturb, grid%field_t_tend_perturb, &
- config_flags%spec_bdy_width, grid%spec_zone, &
- grid%num_stoch_levels, & ! stoch dims
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- ips,ipe, jps,jpe, kps,kpe, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
-
- ENDIF
-
- END DO
- !$OMP END PARALLEL DO
-BENCH_END(relax_bdy_dry_tim)
-
-!
-!
-! (3) Small (acoustic,sound) steps.
-!
-! Several acoustic steps are taken each RK pass. A small step
-! sequence begins with calculating perturbation variables
-! and coupling them to the column dry-air-mass mu
-! (call to small_step_prep). This is followed by computing
-! coefficients for the vertically implicit part of the
-! small timestep (call to calc_coef_w).
-!
-! The small steps are taken
-! in the named loop "small_steps:". In the small_steps loop, first
-! the horizontal momentum (u and v) are advanced (call to advance_uv),
-! next mu and theta are advanced (call to advance_mu_t) followed by
-! advancing w and the geopotential (call to advance_w). Diagnostic
-! values for pressure and inverse density are updated at the end of
-! each small_step.
-!
-! The small-step section ends with the change of the perturbation variables
-! back to full variables (call to small_step_finish).
-!
-!
-
-BENCH_START(small_step_prep_tim)
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
-
- ! Calculate coefficients for the vertically implicit acoustic/gravity wave
- ! integration. We only need calculate these for the first pass through -
- ! the predictor step. They are reused as is for the corrector step.
- ! For third-order RK, we need to recompute these after the first
- ! predictor because we may have changed the small timestep -> grid%dts.
-
- CALL wrf_debug ( 200 , ' call small_step_prep ' )
-
- CALL small_step_prep( grid%u_1,grid%u_2,grid%v_1,grid%v_2,grid%w_1,grid%w_2, &
- grid%t_1,grid%t_2,grid%ph_1,grid%ph_2, &
- grid%mub, grid%mu_1, grid%mu_2, &
- grid%muu, grid%muus, grid%muv, grid%muvs, &
- grid%mut, grid%muts, grid%mudf, &
- grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
- grid%c3h, grid%c4h, grid%c3f, grid%c4f, &
- grid%u_save, grid%v_save, w_save, &
- grid%t_save, ph_save, mu_save, &
- grid%ww, ww1, &
- c2a, grid%pb, grid%p, grid%alt, &
- grid%msfux,grid%msfuy, grid%msfvx, grid%msfvx_inv, &
- grid%msfvy, grid%msftx,grid%msfty, &
- grid%rdx, grid%rdy, rk_step, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- CALL calc_p_rho( grid%al, grid%p, grid%ph_2, &
- grid%alt, grid%t_2, grid%t_save, c2a, pm1, &
- grid%mu_2, grid%muts, &
- grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
- grid%c3h, grid%c4h, grid%c3f, grid%c4f, &
- grid%znu, t0, &
- grid%rdnw, grid%dnw, grid%smdiv, &
- config_flags%non_hydrostatic, 0, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- IF (config_flags%non_hydrostatic) THEN
- CALL calc_coef_w( a,alpha,gamma, &
- grid%mut, &
- grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
- grid%c3h, grid%c4h, grid%c3f, grid%c4f, &
- cqw, grid%rdn, grid%rdnw, c2a, &
- dts_rk, g, grid%epssm, &
- config_flags%top_lid, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- ENDIF
-
- ENDDO
- !$OMP END PARALLEL DO
-BENCH_END(small_step_prep_tim)
-
-#ifdef DM_PARALLEL
-!-----------------------------------------------------------------------
-! Stencils for patch communications (WCS, 29 June 2001)
-! Note: the small size of this halo exchange reflects the
-! fact that we are carrying the uncoupled variables
-! as state variables in the mass coordinate model, as
-! opposed to the coupled variables as in the height
-! coordinate model.
-!
-! * * * * *
-! * * * * * * * * *
-! * + * * + * * * + * *
-! * * * * * * * * *
-! * * * * *
-!
-! 3D variables - note staggering! ph_2(Z), u_save(X), v_save(Y)
-!
-! ph_2 x
-! al x
-! p x
-! t_1 x
-! t_save x
-! u_save x
-! v_save x
-!
-! the following are 2D (xy) variables
-!
-! mu_1 x
-! mu_2 x
-! mudf x
-! php x
-! alt x
-! pb x
-!--------------------------------------------------------------
-# include "HALO_EM_B.inc"
-# include "PERIOD_BDY_EM_B.inc"
-#endif
-
-BENCH_START(set_phys_bc2_tim)
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
-
- DO ij = 1 , grid%num_tiles
-
- CALL set_physical_bc3d( grid%ru_tend, 'u', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- CALL set_physical_bc3d( grid%rv_tend, 'v', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- CALL set_physical_bc3d( grid%ph_2, 'w', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- CALL set_physical_bc3d( grid%al, 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- CALL set_physical_bc3d( grid%p, 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- CALL set_physical_bc3d( grid%t_1, 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- CALL set_physical_bc3d( grid%t_save, 't', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- CALL set_physical_bc2d( grid%mu_1, 't', config_flags, &
- ids, ide, jds, jde, &
- ims, ime, jms, jme, &
- ips, ipe, jps, jpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij) )
-
- CALL set_physical_bc2d( grid%mu_2, 't', config_flags, &
- ids, ide, jds, jde, &
- ims, ime, jms, jme, &
- ips, ipe, jps, jpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij) )
-
- CALL set_physical_bc2d( grid%mudf, 't', config_flags, &
- ids, ide, jds, jde, &
- ims, ime, jms, jme, &
- ips, ipe, jps, jpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij) )
-
- END DO
- !$OMP END PARALLEL DO
-BENCH_END(set_phys_bc2_tim)
- small_steps : DO iteration = 1 , number_of_small_timesteps
-
- ! Boundary condition time (or communication time).
-#ifdef DM_PARALLEL
-# include "PERIOD_BDY_EM_B.inc"
-#endif
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
-
- DO ij = 1 , grid%num_tiles
-
-BENCH_START(advance_uv_tim)
- CALL advance_uv ( grid%u_2, grid%ru_tend, grid%v_2, grid%rv_tend, &
- grid%p, grid%pb, &
- grid%ph_2, grid%php, grid%alt, grid%al, &
- grid%mu_2, grid%muu, cqu, grid%muv, cqv, grid%mudf, &
- grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
- grid%c3h, grid%c4h, grid%c3f, grid%c4f, &
- grid%msfux, grid%msfuy, grid%msfvx, &
- grid%msfvx_inv, grid%msfvy, &
- grid%rdx, grid%rdy, dts_rk, &
- grid%cf1, grid%cf2, grid%cf3, grid%fnm, grid%fnp, &
- grid%emdiv, &
- grid%rdnw, config_flags,grid%spec_zone, &
- config_flags%non_hydrostatic, config_flags%top_lid, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-BENCH_END(advance_uv_tim)
-
- END DO
- !$OMP END PARALLEL DO
-
-!-----------------------------------------------------------
-! acoustic integration polar filter for smallstep u, v
-!-----------------------------------------------------------
-
- IF (config_flags%polar) THEN
-
- CALL pxft ( grid=grid &
- ,lineno=__LINE__ &
- ,flag_uv = 1 &
- ,flag_rurv = 0 &
- ,flag_wph = 0 &
- ,flag_ww = 0 &
- ,flag_t = 0 &
- ,flag_mu = 0 &
- ,flag_mut = 0 &
- ,flag_moist = 0 &
- ,flag_chem = 0 &
- ,flag_tracer = 0 &
- ,flag_scalar = 0 &
- ,actual_distance_average = .FALSE. &
- ,pos_def = .FALSE. &
- ,swap_pole_with_next_j = .FALSE. &
- ,moist=moist,chem=chem,tracer=tracer,scalar=scalar &
- ,fft_filter_lat = config_flags%fft_filter_lat &
- ,dclat = dclat &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe &
- ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
- ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
-
- END IF
-
-!-----------------------------------------------------------
-! end acoustic integration polar filter for smallstep u, v
-!-----------------------------------------------------------
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
-
-BENCH_START(spec_bdy_uv_tim)
- IF( config_flags%specified .or. config_flags%nested ) THEN
- CALL spec_bdyupdate(grid%u_2, grid%ru_tend, dts_rk, &
- 'u' , config_flags, &
- grid%spec_zone, &
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- ips,ipe, jps,jpe, kps,kpe, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- CALL spec_bdyupdate(grid%v_2, grid%rv_tend, dts_rk, &
- 'v' , config_flags, &
- grid%spec_zone, &
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- ips,ipe, jps,jpe, kps,kpe, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- ENDIF
-BENCH_END(spec_bdy_uv_tim)
-
- END DO
- !$OMP END PARALLEL DO
-
-#ifdef DM_PARALLEL
-!
-! Stencils for patch communications (WCS, 29 June 2001)
-!
-! * *
-! * + * * + * +
-! * *
-!
-! u_2 x
-! v_2 x
-!
-# include "HALO_EM_C.inc"
-#endif
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
-
- ! advance the mass in the column, theta, and calculate ww
-
-BENCH_START(advance_mu_t_tim)
- CALL advance_mu_t( grid%ww, ww1, grid%u_2, grid%u_save, grid%v_2, grid%v_save, &
- grid%mu_2, grid%mut, muave, grid%muts, grid%muu, grid%muv, &
- grid%mudf, &
- grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
- grid%c3h, grid%c4h, grid%c3f, grid%c4f, &
- grid%ru_m, grid%rv_m, grid%ww_m, &
- grid%t_2, grid%t_save, t_2save, t_tend, &
- mu_tend, &
- grid%rdx, grid%rdy, dts_rk, grid%epssm, &
- grid%dnw, grid%fnm, grid%fnp, grid%rdnw, &
- grid%msfux,grid%msfuy, grid%msfvx, grid%msfvx_inv, &
- grid%msfvy, grid%msftx,grid%msfty, &
- iteration, config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-BENCH_END(advance_mu_t_tim)
- ENDDO
- !$OMP END PARALLEL DO
-
-!-----------------------------------------------------------
-! acoustic integration polar filter for smallstep mu, t
-!-----------------------------------------------------------
-
- IF ( (config_flags%polar) ) THEN
-
- CALL pxft ( grid=grid &
- ,lineno=__LINE__ &
- ,flag_uv = 0 &
- ,flag_rurv = 0 &
- ,flag_wph = 0 &
- ,flag_ww = 0 &
- ,flag_t = 1 &
- ,flag_mu = 1 &
- ,flag_mut = 0 &
- ,flag_moist = 0 &
- ,flag_chem = 0 &
- ,flag_tracer = 0 &
- ,flag_scalar = 0 &
- ,actual_distance_average = .FALSE. &
- ,pos_def = .FALSE. &
- ,swap_pole_with_next_j = .FALSE. &
- ,moist=moist,chem=chem,tracer=tracer,scalar=scalar &
- ,fft_filter_lat = config_flags%fft_filter_lat &
- ,dclat = dclat &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe &
- ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
- ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
-
- grid%muts = grid%mut + grid%mu_2 ! reset muts using filtered mu_2
-
- END IF
-
-!-----------------------------------------------------------
-! end acoustic integration polar filter for smallstep mu, t
-!-----------------------------------------------------------
-
-BENCH_START(spec_bdy_t_tim)
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
-
- IF( config_flags%specified .or. config_flags%nested ) THEN
-
- CALL spec_bdyupdate(grid%t_2, t_tend, dts_rk, &
- 't' , config_flags, &
- grid%spec_zone, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- ips,ipe, jps,jpe, kps,kpe, &
- grid%i_start(ij), grid%i_end(ij),&
- grid%j_start(ij), grid%j_end(ij),&
- k_start , k_end )
-
- CALL spec_bdyupdate(grid%mu_2, mu_tend, dts_rk, &
- 'm' , config_flags, &
- grid%spec_zone, &
- ids,ide, jds,jde, 1 ,1 , &
- ims,ime, jms,jme, 1 ,1 , &
- ips,ipe, jps,jpe, 1 ,1 , &
- grid%i_start(ij), grid%i_end(ij),&
- grid%j_start(ij), grid%j_end(ij),&
- 1 , 1 )
-
- CALL spec_bdyupdate(grid%muts, mu_tend, dts_rk, &
- 'm' , config_flags, &
- grid%spec_zone, &
- ids,ide, jds,jde, 1 ,1 , & ! domain dims
- ims,ime, jms,jme, 1 ,1 , & ! memory dims
- ips,ipe, jps,jpe, 1 ,1 , & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- 1 , 1 )
- ENDIF
-BENCH_END(spec_bdy_t_tim)
-
- ! small (acoustic) step for the vertical momentum,
- ! density and coupled potential temperature.
-
-
-BENCH_START(advance_w_tim)
- IF ( config_flags%non_hydrostatic ) THEN
- CALL advance_w( grid%w_2, rw_tend, grid%ww, w_save, &
- grid%u_2, grid%v_2, &
- grid%mu_2, grid%mut, muave, grid%muts, &
- grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
- grid%c3h, grid%c4h, grid%c3f, grid%c4f, &
- t_2save, grid%t_2, grid%t_save, &
- grid%ph_2, ph_save, grid%phb, ph_tend, &
- grid%ht, c2a, cqw, grid%alt, grid%alb, &
- a, alpha, gamma, &
- grid%rdx, grid%rdy, dts_rk, t0, grid%epssm, &
- grid%dnw, grid%fnm, grid%fnp, grid%rdnw, &
- grid%rdn, grid%cf1, grid%cf2, grid%cf3, &
- grid%msftx, grid%msfty, &
- config_flags, config_flags%top_lid, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- ENDIF
-BENCH_END(advance_w_tim)
-
- ENDDO
- !$OMP END PARALLEL DO
-
-!-----------------------------------------------------------
-! acoustic integration polar filter for smallstep w, geopotential
-!-----------------------------------------------------------
-
- IF ( (config_flags%polar) .AND. (config_flags%non_hydrostatic) ) THEN
-
- CALL pxft ( grid=grid &
- ,lineno=__LINE__ &
- ,flag_uv = 0 &
- ,flag_rurv = 0 &
- ,flag_wph = 1 &
- ,flag_ww = 0 &
- ,flag_t = 0 &
- ,flag_mu = 0 &
- ,flag_mut = 0 &
- ,flag_moist = 0 &
- ,flag_chem = 0 &
- ,flag_tracer = 0 &
- ,flag_scalar = 0 &
- ,actual_distance_average = .FALSE. &
- ,pos_def = .FALSE. &
- ,swap_pole_with_next_j = .FALSE. &
- ,moist=moist,chem=chem,tracer=tracer,scalar=scalar &
- ,fft_filter_lat = config_flags%fft_filter_lat &
- ,dclat = dclat &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe &
- ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
- ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
-
- END IF
-
-!-----------------------------------------------------------
-! end acoustic integration polar filter for smallstep w, geopotential
-!-----------------------------------------------------------
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
-
-BENCH_START(sumflux_tim)
- CALL sumflux ( grid%u_2, grid%v_2, grid%ww, &
- grid%u_save, grid%v_save, ww1, &
- grid%muu, grid%muv, &
- grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
- grid%c3h, grid%c4h, grid%c3f, grid%c4f, &
- grid%ru_m, grid%rv_m, grid%ww_m, grid%epssm, &
- grid%msfux, grid% msfuy, grid%msfvx, &
- grid%msfvx_inv, grid%msfvy, &
- iteration, number_of_small_timesteps, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-BENCH_END(sumflux_tim)
-
- IF( config_flags%specified .or. config_flags%nested ) THEN
-
-BENCH_START(spec_bdynhyd_tim)
- IF (config_flags%non_hydrostatic) THEN
- CALL spec_bdyupdate_ph( ph_save, grid%ph_2, ph_tend, &
- mu_tend, grid%muts, &
- grid%c1f, grid%c2f, dts_rk, &
- 'h' , config_flags, &
- grid%spec_zone, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- ips,ipe, jps,jpe, kps,kpe, &
- grid%i_start(ij), grid%i_end(ij),&
- grid%j_start(ij), grid%j_end(ij),&
- k_start , k_end )
- IF( config_flags%specified ) THEN
- CALL zero_grad_bdy ( grid%w_2, &
- 'w' , config_flags, &
- grid%spec_zone, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- ips,ipe, jps,jpe, kps,kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- ELSE
- CALL spec_bdyupdate ( grid%w_2, rw_tend, dts_rk, &
- 'h' , config_flags, &
- grid%spec_zone, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- ips,ipe, jps,jpe, kps,kpe, &
- grid%i_start(ij), grid%i_end(ij),&
- grid%j_start(ij), grid%j_end(ij),&
- k_start , k_end )
- ENDIF
- ENDIF
-BENCH_END(spec_bdynhyd_tim)
- ENDIF
-
-BENCH_START(cald_p_rho_tim)
- CALL calc_p_rho( grid%al, grid%p, grid%ph_2, &
- grid%alt, grid%t_2, grid%t_save, c2a, pm1, &
- grid%mu_2, grid%muts, &
- grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
- grid%c3h, grid%c4h, grid%c3f, grid%c4f, &
- grid%znu, t0, &
- grid%rdnw, grid%dnw, grid%smdiv, &
- config_flags%non_hydrostatic, iteration, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-BENCH_END(cald_p_rho_tim)
-
- ENDDO
- !$OMP END PARALLEL DO
-
-#ifdef DM_PARALLEL
-!
-! Stencils for patch communications (WCS, 29 June 2001)
-!
-! * *
-! * + * * + * +
-! * *
-!
-! ph_2 x
-! al x
-! p x
-!
-! 2D variables (x,y)
-!
-! mu_2 x
-! muts x
-! mudf x
-
-# include "HALO_EM_C2.inc"
-# include "PERIOD_BDY_EM_B3.inc"
-#endif
-
-BENCH_START(phys_bc_tim)
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
-
- ! boundary condition set for next small timestep
-
- CALL set_physical_bc3d( grid%ph_2, 'w', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- CALL set_physical_bc3d( grid%al, 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- CALL set_physical_bc3d( grid%p, 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- CALL set_physical_bc2d( grid%muts, 't', config_flags, &
- ids, ide, jds, jde, &
- ims, ime, jms, jme, &
- ips, ipe, jps, jpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij) )
-
- CALL set_physical_bc2d( grid%mu_2, 't', config_flags, &
- ids, ide, jds, jde, &
- ims, ime, jms, jme, &
- ips, ipe, jps, jpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij) )
-
- CALL set_physical_bc2d( grid%mudf, 't', config_flags, &
- ids, ide, jds, jde, &
- ims, ime, jms, jme, &
- ips, ipe, jps, jpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij) )
-
- END DO
- !$OMP END PARALLEL DO
-BENCH_END(phys_bc_tim)
-
- END DO small_steps
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
-
- CALL wrf_debug ( 200 , ' call rk_small_finish' )
-
- ! change time-perturbation variables back to
- ! full perturbation variables.
- ! first get updated mu at u and v points
-
-BENCH_START(calc_mu_uv_tim)
- CALL calc_mu_uv_1 ( config_flags, &
- grid%muts, grid%muus, grid%muvs, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-BENCH_END(calc_mu_uv_tim)
-BENCH_START(small_step_finish_tim)
- CALL small_step_finish( grid%u_2, grid%u_1, grid%v_2, grid%v_1, grid%w_2, grid%w_1, &
- grid%t_2, grid%t_1, grid%ph_2, grid%ph_1, grid%ww, ww1, &
- grid%mu_2, grid%mu_1, &
- grid%mut, grid%muts, grid%muu, grid%muus, grid%muv, grid%muvs, &
- grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
- grid%c3h, grid%c4h, grid%c3f, grid%c4f, &
- grid%u_save, grid%v_save, w_save, &
- grid%t_save, ph_save, mu_save, &
- grid%msfux,grid%msfuy, grid%msfvx,grid%msfvy, grid%msftx,grid%msfty, &
- grid%h_diabatic, &
- number_of_small_timesteps,dts_rk, &
- rk_step, rk_order, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-! call to set ru_m, rv_m and ww_m b.c's for PD advection
-
- IF (rk_step == rk_order) THEN
-
- CALL set_physical_bc3d( grid%ru_m, 'u', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- CALL set_physical_bc3d( grid%rv_m, 'v', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- CALL set_physical_bc3d( grid%ww_m, 'w', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- CALL set_physical_bc2d( grid%mut, 't', config_flags, &
- ids, ide, jds, jde, &
- ims, ime, jms, jme, &
- ips, ipe, jps, jpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij) )
-
- CALL set_physical_bc2d( grid%muts, 't', config_flags, &
- ids, ide, jds, jde, &
- ims, ime, jms, jme, &
- ips, ipe, jps, jpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij) )
-
- END IF
-
-BENCH_END(small_step_finish_tim)
-
- END DO
- !$OMP END PARALLEL DO
-
-!-----------------------------------------------------------
-! polar filter for full dynamics variables and time-averaged mass fluxes
-!-----------------------------------------------------------
-
- IF (config_flags%polar) THEN
-
- CALL pxft ( grid=grid &
- ,lineno=__LINE__ &
- ,flag_uv = 1 &
- ,flag_rurv = 1 &
- ,flag_wph = 1 &
- ,flag_ww = 1 &
- ,flag_t = 1 &
- ,flag_mu = 1 &
- ,flag_mut = 1 &
- ,flag_moist = 0 &
- ,flag_chem = 0 &
- ,flag_tracer = 0 &
- ,flag_scalar = 0 &
- ,actual_distance_average = .FALSE. &
- ,pos_def = .FALSE. &
- ,swap_pole_with_next_j = .FALSE. &
- ,moist=moist,chem=chem,tracer=tracer,scalar=scalar &
- ,fft_filter_lat = config_flags%fft_filter_lat &
- ,dclat = dclat &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe &
- ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
- ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
-
- END IF
-
-!-----------------------------------------------------------
-! end polar filter for full dynamics variables and time-averaged mass fluxes
-!-----------------------------------------------------------
-
-!-----------------------------------------------------------------------
-! add in physics tendency first if positive definite advection is used.
-! pd advection applies advective flux limiter on last runge-kutta step
-!-----------------------------------------------------------------------
-! first moisture
-
- IF ((config_flags%moist_adv_opt /= ORIGINAL .and. config_flags%moist_adv_opt /= WENO_SCALAR) .and. &
- (rk_step == rk_order)) THEN
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
- CALL wrf_debug ( 200 , ' call rk_update_scalar_pd' )
- DO im = PARAM_FIRST_SCALAR, num_3d_m
- CALL rk_update_scalar_pd( im, im, &
- moist_old(ims,kms,jms,im), &
- moist_tend(ims,kms,jms,im), &
- grid%c1h, grid%c2h, &
- grid%mu_1, grid%mu_1, grid%mub, &
- rk_step, dt_rk, grid%spec_zone, &
- config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- ENDDO
- END DO
- !$OMP END PARALLEL DO
-
-!---------------------- positive definite bc call
-#ifdef DM_PARALLEL
- IF (config_flags%moist_adv_opt /= ORIGINAL .and. config_flags%moist_adv_opt /= WENO_SCALAR) THEN
- IF ( config_flags%h_sca_adv_order <= 4 ) THEN
-# include "HALO_EM_MOIST_OLD_E_5.inc"
- ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
-# include "HALO_EM_MOIST_OLD_E_7.inc"
- ELSE
- WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
- CALL wrf_error_fatal(TRIM(wrf_err_message))
- ENDIF
- ENDIF
-#endif
-
-#ifdef DM_PARALLEL
-# include "PERIOD_BDY_EM_MOIST_OLD.inc"
-#endif
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
- IF (num_3d_m >= PARAM_FIRST_SCALAR) THEN
- DO im = PARAM_FIRST_SCALAR , num_3d_m
- CALL set_physical_bc3d( moist_old(ims,kms,jms,im), 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- END DO
- ENDIF
- END DO
- !$OMP END PARALLEL DO
-
- END IF ! end if for moist_adv_opt
-
-! scalars
-
- IF ((config_flags%scalar_adv_opt /= ORIGINAL .and. config_flags%scalar_adv_opt /= WENO_SCALAR) .and. &
- (rk_step == rk_order)) THEN
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
- CALL wrf_debug ( 200 , ' call rk_update_scalar_pd' )
- DO im = PARAM_FIRST_SCALAR, num_3d_s
- CALL rk_update_scalar_pd( im, im, &
- scalar_old(ims,kms,jms,im), &
- scalar_tend(ims,kms,jms,im), &
- grid%c1h, grid%c2h, &
- grid%mu_1, grid%mu_1, grid%mub, &
- rk_step, dt_rk, grid%spec_zone, &
- config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- ENDDO
- ENDDO
- !$OMP END PARALLEL DO
-
-!---------------------- positive definite bc call
-#ifdef DM_PARALLEL
- IF (config_flags%scalar_adv_opt /= ORIGINAL .and. config_flags%scalar_adv_opt /= WENO_SCALAR) THEN
-#ifndef RSL
- IF ( config_flags%h_sca_adv_order <= 4 ) THEN
-# include "HALO_EM_SCALAR_OLD_E_5.inc"
- ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
-# include "HALO_EM_SCALAR_OLD_E_7.inc"
- ELSE
- WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
- CALL wrf_error_fatal(TRIM(wrf_err_message))
- ENDIF
-#else
- WRITE(wrf_err_message,*)'cannot use pd scheme with RSL - use RSL-LITE'
- CALL wrf_error_fatal(TRIM(wrf_err_message))
-#endif
- endif
-#endif
-
-#ifdef DM_PARALLEL
-# include "PERIOD_BDY_EM_SCALAR_OLD.inc"
-#endif
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
-
- DO ij = 1 , grid%num_tiles
- IF (num_3d_s >= PARAM_FIRST_SCALAR) THEN
- DO im = PARAM_FIRST_SCALAR , num_3d_s
- CALL set_physical_bc3d( scalar_old(ims,kms,jms,im), 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- END DO
- ENDIF
- END DO
- !$OMP END PARALLEL DO
-
- END IF ! end if for scalar_adv_opt
-
-! chem
-
- IF ((config_flags%chem_adv_opt /= ORIGINAL .and. config_flags%chem_adv_opt /= WENO_SCALAR) .and. (rk_step == rk_order)) THEN
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
- CALL wrf_debug ( 200 , ' call rk_update_scalar_pd' )
- DO im = PARAM_FIRST_SCALAR, num_3d_c
- CALL rk_update_scalar_pd( im, im, &
- chem_old(ims,kms,jms,im), &
- chem_tend(ims,kms,jms,im), &
- grid%c1h, grid%c2h, &
- grid%mu_1, grid%mu_1, grid%mub, &
- rk_step, dt_rk, grid%spec_zone, &
- config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- ENDDO
- END DO
- !$OMP END PARALLEL DO
-
-!---------------------- positive definite bc call
-#ifdef DM_PARALLEL
- IF (config_flags%chem_adv_opt /= ORIGINAL .and. config_flags%chem_adv_opt /= WENO_SCALAR) THEN
- IF ( config_flags%h_sca_adv_order <= 4 ) THEN
-# include "HALO_EM_CHEM_OLD_E_5.inc"
- ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
-# include "HALO_EM_CHEM_OLD_E_7.inc"
- ELSE
- WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
- CALL wrf_error_fatal(TRIM(wrf_err_message))
- ENDIF
- ENDIF
-#endif
-
-#ifdef DM_PARALLEL
-# include "PERIOD_BDY_EM_CHEM_OLD.inc"
-#endif
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
- IF (num_3d_c >= PARAM_FIRST_SCALAR) THEN
- DO im = PARAM_FIRST_SCALAR , num_3d_c
- CALL set_physical_bc3d( chem_old(ims,kms,jms,im), 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- END DO
- ENDIF
- END DO
- !$OMP END PARALLEL DO
-
- ENDIF ! end if for chem_adv_opt
-
-! tracer
-
- IF ((config_flags%tracer_adv_opt /= ORIGINAL .and. config_flags%tracer_adv_opt /= WENO_SCALAR) .and. (rk_step == rk_order)) THEN
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
- CALL wrf_debug ( 200 , ' call rk_update_scalar_pd' )
- DO im = PARAM_FIRST_SCALAR, num_tracer
- CALL rk_update_scalar_pd( im, im, &
- tracer_old(ims,kms,jms,im), &
- tracer_tend(ims,kms,jms,im), &
- grid%c1h, grid%c2h, &
- grid%mu_1, grid%mu_1, grid%mub, &
- rk_step, dt_rk, grid%spec_zone, &
- config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- ENDDO
- END DO
- !$OMP END PARALLEL DO
-
-!---------------------- positive definite bc call
-#ifdef DM_PARALLEL
- IF (config_flags%tracer_adv_opt /= ORIGINAL .and. config_flags%tracer_adv_opt /= WENO_SCALAR) THEN
- IF ( config_flags%h_sca_adv_order <= 4 ) THEN
-# include "HALO_EM_TRACER_OLD_E_5.inc"
- ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
-# include "HALO_EM_TRACER_OLD_E_7.inc"
- ELSE
- WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
- CALL wrf_error_fatal(TRIM(wrf_err_message))
- ENDIF
- ENDIF
-#endif
-
-#ifdef DM_PARALLEL
-# include "PERIOD_BDY_EM_TRACER_OLD.inc"
-#endif
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
- IF (num_tracer >= PARAM_FIRST_SCALAR) THEN
- DO im = PARAM_FIRST_SCALAR , num_tracer
- CALL set_physical_bc3d( tracer_old(ims,kms,jms,im), 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- END DO
- ENDIF
- END DO
- !$OMP END PARALLEL DO
-
- ENDIF ! end if for tracer_adv_opt
-
-! tke
-
- IF ((config_flags%tke_adv_opt /= ORIGINAL .and. config_flags%tke_adv_opt /= WENO_SCALAR) .and. (rk_step == rk_order) &
- .and. (config_flags%km_opt .eq. 2) ) THEN
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
- CALL wrf_debug ( 200 , ' call rk_update_scalar_pd' )
- CALL rk_update_scalar_pd( 1, 1, &
- grid%tke_1, &
- tke_tend(ims,kms,jms), &
- grid%c1h, grid%c2h, &
- grid%mu_1, grid%mu_1, grid%mub, &
- rk_step, dt_rk, grid%spec_zone, &
- config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- ENDDO
- !$OMP END PARALLEL DO
-
-!---------------------- positive definite bc call
-#ifdef DM_PARALLEL
- IF (config_flags%tke_adv_opt /= ORIGINAL .and. config_flags%tke_adv_opt /= WENO_SCALAR) THEN
- IF ( config_flags%h_sca_adv_order <= 4 ) THEN
-# include "HALO_EM_TKE_OLD_E_5.inc"
- ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
-# include "HALO_EM_TKE_OLD_E_7.inc"
- ELSE
- WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
- CALL wrf_error_fatal(TRIM(wrf_err_message))
- ENDIF
- ENDIF
-#endif
-
-#ifdef DM_PARALLEL
-# include "PERIOD_BDY_EM_TKE_OLD.inc"
-#endif
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
- CALL set_physical_bc3d( grid%tke_1, 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- END DO
- !$OMP END PARALLEL DO
-
-!--- end of positive definite physics tendency update
-
- END IF ! end if for tke_adv_opt
-
-#ifdef DM_PARALLEL
-!
-! Stencils for patch communications (WCS, 29 June 2001)
-!
-! * * * * *
-! * * * * *
-! * * + * *
-! * * * * *
-! * * * * *
-!
-! ru_m x
-! rv_m x
-! ww_m x
-! mut x
-!
-!--------------------------------------------------------------
-
-# include "HALO_EM_D.inc"
-! WCS addition 11/19/08
-# include "PERIOD_EM_DA.inc"
-#endif
-
-!
-!
-! (4) Still within the RK loop, the scalar variables are advanced.
-!
-! For the moist and chem variables, each one is advanced
-! individually, using named loops "moist_variable_loop:"
-! and "chem_variable_loop:". Each RK substep begins by
-! calculating the advective tendency, and, for the first RK step,
-! 3D mixing (calling rk_scalar_tend) followed by an update
-! of the scalar (calling rk_update_scalar).
-!
-!
-
-
- moist_scalar_advance: IF (num_3d_m >= PARAM_FIRST_SCALAR ) THEN
-
- moist_variable_loop: DO im = PARAM_FIRST_SCALAR, num_3d_m
-
-! adv_moist_cond is set in module_physics_init based on mp_physics choice
-! true except for Ferrier scheme
-
- IF (grid%adv_moist_cond .or. im==p_qv ) THEN
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij, tenddec )
- moist_tile_loop_1: DO ij = 1 , grid%num_tiles
-
- CALL wrf_debug ( 200 , ' call rk_scalar_tend' )
- tenddec = .false.
-
-BENCH_START(rk_scalar_tend_tim)
- CALL rk_scalar_tend ( im, im, config_flags, tenddec, &
- rk_step, dt_rk, &
- grid%ru_m, grid%rv_m, grid%ww_m, wwE, wwI, &
- grid%u_1, grid%v_1, &
- grid%muts, grid%mub, grid%mu_1, &
- grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
- grid%alt, &
- moist_old(ims,kms,jms,im), &
- moist(ims,kms,jms,im), &
- moist_tend(ims,kms,jms,im), &
- advect_tend,h_tendency,z_tendency,grid%rqvften, &
- grid%qv_base, .true., grid%fnm, grid%fnp, &
- grid%msfux,grid%msfuy, grid%msfvx, grid%msfvx_inv,&
- grid%msfvy, grid%msftx,grid%msfty, &
- grid%rdx, grid%rdy, grid%rdn, grid%rdnw, grid%khdif, &
- grid%kvdif, grid%xkhh, &
- grid%diff_6th_opt, grid%diff_6th_factor, &
- config_flags%moist_adv_opt, &
- grid%phb, grid%ph_2, &
- config_flags%moist_mix2_off, &
- config_flags%moist_mix6_off, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- IF( rk_step == 1 .AND. config_flags%use_q_diabatic == 1 )THEN
- IF( im.eq.p_qv .or. im.eq.p_qc )THEN
- CALL q_diabatic_add ( im, im, &
- dt_rk, grid%mut, &
- grid%c1h, grid%c2h, &
- grid%qv_diabatic, &
- grid%qc_diabatic, &
- moist_tend(ims,kms,jms,im), &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- ENDIF
- ENDIF
-
-BENCH_END(rk_scalar_tend_tim)
-
-BENCH_START(rlx_bdy_scalar_tim)
- IF( ( config_flags%specified .or. config_flags%nested ) .and. rk_step == 1 ) THEN
- IF ( im .EQ. P_QV .OR. config_flags%nested .OR. &
- ( config_flags%specified .AND. config_flags%have_bcs_moist ) ) THEN
- CALL relax_bdy_scalar ( moist_tend(ims,kms,jms,im), &
- moist(ims,kms,jms,im), grid%mut, &
- grid%c1h, grid%c2h, &
- moist_bxs(jms,kms,1,im),moist_bxe(jms,kms,1,im), &
- moist_bys(ims,kms,1,im),moist_bye(ims,kms,1,im), &
- moist_btxs(jms,kms,1,im),moist_btxe(jms,kms,1,im), &
- moist_btys(ims,kms,1,im),moist_btye(ims,kms,1,im), &
- config_flags%spec_bdy_width, grid%spec_zone, grid%relax_zone, &
- grid%dtbc, grid%fcx, grid%gcx, &
- config_flags, &
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- ips,ipe, jps,jpe, kps,kpe, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
-
- CALL spec_bdy_scalar ( moist_tend(ims,kms,jms,im), &
- moist_bxs(jms,kms,1,im),moist_bxe(jms,kms,1,im), &
- moist_bys(ims,kms,1,im),moist_bye(ims,kms,1,im), &
- moist_btxs(jms,kms,1,im),moist_btxe(jms,kms,1,im), &
- moist_btys(ims,kms,1,im),moist_btye(ims,kms,1,im), &
- config_flags%spec_bdy_width, grid%spec_zone, &
- config_flags, &
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- ips,ipe, jps,jpe, kps,kpe, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
- ENDIF
- ENDIF
-BENCH_END(rlx_bdy_scalar_tim)
-
- ENDDO moist_tile_loop_1
- !$OMP END PARALLEL DO
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij, tenddec )
- moist_tile_loop_2: DO ij = 1 , grid%num_tiles
-
- CALL wrf_debug ( 200 , ' call rk_update_scalar' )
- tenddec = .false.
-
-BENCH_START(update_scal_tim)
- CALL rk_update_scalar( scs=im, sce=im, &
- scalar_1=moist_old(ims,kms,jms,im), &
- scalar_2=moist(ims,kms,jms,im), &
- sc_tend=moist_tend(ims,kms,jms,im), &
- advect_tend=advect_tend, &
- h_tendency=h_tendency, z_tendency=z_tendency, &
- msftx=grid%msftx,msfty=grid%msfty, &
- c1=grid%c1h, c2=grid%c2h, &
- mu_old=grid%mu_1, mu_new=grid%mu_2, mu_base=grid%mub, &
- rk_step=rk_step, dt=dt_rk, spec_zone=grid%spec_zone, &
- config_flags=config_flags, tenddec=tenddec, &
- ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, &
- ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, &
- its=grid%i_start(ij), ite=grid%i_end(ij), &
- jts=grid%j_start(ij), jte=grid%j_end(ij), &
- kts=k_start , kte=k_end )
- IF( rk_step == rk_order .AND. config_flags%use_q_diabatic == 1 )THEN
- IF( im.eq.p_qv .or. im.eq.p_qc )THEN
- CALL q_diabatic_subtr( im, im, &
- dt_rk, &
- grid%qv_diabatic, &
- grid%qc_diabatic, &
- moist(ims,kms,jms,im), &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- ENDIF
- ENDIF
-BENCH_END(update_scal_tim)
-
-BENCH_START(flow_depbdy_tim)
- IF( config_flags%specified .AND. ( .NOT. config_flags%have_bcs_moist ) ) THEN
- IF(im .ne. P_QV)THEN
- CALL flow_dep_bdy ( moist(ims,kms,jms,im), &
- grid%ru_m, grid%rv_m, config_flags, &
- grid%spec_zone, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- ips,ipe, jps,jpe, kps,kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
- ENDIF
- ENDIF
-BENCH_END(flow_depbdy_tim)
-
- ENDDO moist_tile_loop_2
- !$OMP END PARALLEL DO
-
- ENDIF !-- if (grid%adv_moist_cond .or. im==p_qv ) then
-
- ENDDO moist_variable_loop
-
- ENDIF moist_scalar_advance
-
-BENCH_START(tke_adv_tim)
- TKE_advance: IF (config_flags%km_opt .eq. 2.or.config_flags%km_opt.eq.5) then ! XZ
-#ifdef DM_PARALLEL
- IF ( config_flags%h_sca_adv_order <= 4 ) THEN
-# include "HALO_EM_TKE_ADVECT_3.inc"
- ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
-# include "HALO_EM_TKE_ADVECT_5.inc"
- ELSE
- WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
- CALL wrf_error_fatal(TRIM(wrf_err_message))
- ENDIF
-#endif
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij, tenddec )
- tke_tile_loop_1: DO ij = 1 , grid%num_tiles
-
- CALL wrf_debug ( 200 , ' call rk_scalar_tend for tke' )
- tenddec = .false.
- CALL rk_scalar_tend ( 1, 1, config_flags, tenddec, &
- rk_step, dt_rk, &
- grid%ru_m, grid%rv_m, grid%ww_m, wwE, wwI, &
- grid%u_1, grid%v_1, &
- grid%muts, grid%mub, grid%mu_1, &
- grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
- grid%alt, &
- grid%tke_1, &
- grid%tke_2, &
- tke_tend(ims,kms,jms), &
- advect_tend,h_tendency,z_tendency,grid%rqvften, &
- grid%qv_base, .false., grid%fnm, grid%fnp, &
- grid%msfux,grid%msfuy, grid%msfvx, grid%msfvx_inv, &
- grid%msfvy, grid%msftx,grid%msfty, &
- grid%rdx, grid%rdy, grid%rdn, grid%rdnw, grid%khdif, &
- grid%kvdif, grid%xkhh, &
- grid%diff_6th_opt, grid%diff_6th_factor, &
- config_flags%tke_adv_opt, &
- grid%phb, grid%ph_2, &
- config_flags%tke_mix2_off, &
- config_flags%tke_mix6_off, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- ENDDO tke_tile_loop_1
- !$OMP END PARALLEL DO
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij, tenddec )
- tke_tile_loop_2: DO ij = 1 , grid%num_tiles
-
- CALL wrf_debug ( 200 , ' call rk_update_scalar' )
- tenddec = .false.
- CALL rk_update_scalar( scs=1, sce=1, &
- scalar_1=grid%tke_1, &
- scalar_2=grid%tke_2, &
- sc_tend=tke_tend(ims,kms,jms), &
- advect_tend=advect_tend, &
- h_tendency=h_tendency, z_tendency=z_tendency, &
- msftx=grid%msftx,msfty=grid%msfty, &
- c1=grid%c1h, c2=grid%c2h, &
- mu_old=grid%mu_1, mu_new=grid%mu_2, mu_base=grid%mub, &
- rk_step=rk_step, dt=dt_rk, spec_zone=grid%spec_zone, &
- config_flags=config_flags, tenddec=tenddec, &
- ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, &
- ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, &
- its=grid%i_start(ij), ite=grid%i_end(ij), &
- jts=grid%j_start(ij), jte=grid%j_end(ij), &
- kts=k_start , kte=k_end )
-
-! bound the tke (greater than 0, less than tke_upper_bound)
-
- CALL bound_tke( grid%tke_2, grid%tke_upper_bound, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- IF( config_flags%specified .or. config_flags%nested ) THEN
- CALL flow_dep_bdy ( grid%tke_2, &
- grid%ru_m, grid%rv_m, config_flags, &
- grid%spec_zone, &
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- ips,ipe, jps,jpe, kps,kpe, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
- ENDIF
- ENDDO tke_tile_loop_2
- !$OMP END PARALLEL DO
-
- ENDIF TKE_advance
-BENCH_END(tke_adv_tim)
-
-#if (WRF_CHEM == 1)
-! next the chemical species
-BENCH_START(chem_adv_tim)
- chem_scalar_advance: IF (num_3d_c >= PARAM_FIRST_SCALAR) THEN
-
- chem_variable_loop: DO ic = PARAM_FIRST_SCALAR, num_3d_c
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij, tenddec )
- chem_tile_loop_1: DO ij = 1 , grid%num_tiles
-
- CALL wrf_debug ( 200 , ' call rk_scalar_tend in chem_tile_loop_1' )
- tenddec = (( config_flags%chemdiag == USECHEMDIAG ) .and. &
- ( adv_ct_indices(ic) >= PARAM_FIRST_SCALAR ))
- CALL rk_scalar_tend ( ic, ic, config_flags, tenddec, &
- rk_step, dt_rk, &
- grid%ru_m, grid%rv_m, grid%ww_m, wwE, wwI, &
- grid%u_1, grid%v_1, &
- grid%muts, grid%mub, grid%mu_1, &
- grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
- grid%alt, &
- chem_old(ims,kms,jms,ic), &
- chem(ims,kms,jms,ic), &
- chem_tend(ims,kms,jms,ic), &
- advect_tend,h_tendency,z_tendency,grid%rqvften, &
- grid%qv_base, .false., grid%fnm, grid%fnp, &
- grid%msfux,grid%msfuy, grid%msfvx, grid%msfvx_inv, &
- grid%msfvy, grid%msftx,grid%msfty, &
- grid%rdx, grid%rdy, grid%rdn, grid%rdnw, &
- grid%khdif, grid%kvdif, grid%xkhh, &
- grid%diff_6th_opt, grid%diff_6th_factor, &
- config_flags%chem_adv_opt, &
- grid%phb, grid%ph_2, &
- config_flags%chem_mix2_off, &
- config_flags%chem_mix6_off, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-!
-! Currently, chemistry species with specified boundaries (i.e. the mother
-! domain) are being over written by flow_dep_bdy_chem. So, relax_bdy and
-! spec_bdy are only called for nests. For boundary conditions from global model or larger domain,
-! chem is uncoupled, and only used for one row/column on inflow (if have_bcs_chem=.true.)
-!
- IF( ( config_flags%nested ) .and. rk_step == 1 ) THEN
- IF(ic.eq.1)CALL wrf_debug ( 10 , ' have_bcs_chem' )
- CALL relax_bdy_scalar ( chem_tend(ims,kms,jms,ic), &
- chem(ims,kms,jms,ic), grid%mut, &
- grid%c1h, grid%c2h, &
- chem_bxs(jms,kms,1,ic),chem_bxe(jms,kms,1,ic), &
- chem_bys(ims,kms,1,ic),chem_bye(ims,kms,1,ic), &
- chem_btxs(jms,kms,1,ic),chem_btxe(jms,kms,1,ic), &
- chem_btys(ims,kms,1,ic),chem_btye(ims,kms,1,ic), &
- config_flags%spec_bdy_width, grid%spec_zone, grid%relax_zone, &
- grid%dtbc, grid%fcx, grid%gcx, &
- config_flags, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- ips,ipe, jps,jpe, kps,kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
- CALL spec_bdy_scalar ( chem_tend(ims,kms,jms,ic), &
- chem_bxs(jms,kms,1,ic),chem_bxe(jms,kms,1,ic), &
- chem_bys(ims,kms,1,ic),chem_bye(ims,kms,1,ic), &
- chem_btxs(jms,kms,1,ic),chem_btxe(jms,kms,1,ic), &
- chem_btys(ims,kms,1,ic),chem_btye(ims,kms,1,ic), &
- config_flags%spec_bdy_width, grid%spec_zone, &
- config_flags, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- ips,ipe, jps,jpe, kps,kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
- ENDIF
-
- ENDDO chem_tile_loop_1
- !$OMP END PARALLEL DO
-
-if ( config_flags%do_pvozone ) then
-#ifdef DM_PARALLEL
-# include "HALO_EM_D_PV.inc"
-#endif
-end if
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij, tenddec )
-
- chem_tile_loop_2: DO ij = 1 , grid%num_tiles
-
- CALL wrf_debug ( 200 , ' call rk_update_scalar' )
- tenddec = (( config_flags%chemdiag == USECHEMDIAG ) .and. &
- ( adv_ct_indices(ic) >= PARAM_FIRST_SCALAR ))
- CALL rk_update_scalar( scs=ic, sce=ic, &
- scalar_1=chem_old(ims,kms,jms,ic), &
- scalar_2=chem(ims,kms,jms,ic), &
- sc_tend=chem_tend(ims,kms,jms,ic), &
- advh_t=advh_ct(ims,kms,jms,adv_ct_indices(ic)), &
- advz_t=advz_ct(ims,kms,jms,adv_ct_indices(ic)), &
- advect_tend=advect_tend, &
- h_tendency=h_tendency, z_tendency=z_tendency, &
- msftx=grid%msftx,msfty=grid%msfty, &
- c1=grid%c1h, c2=grid%c2h, &
- mu_old=grid%mu_1, mu_new=grid%mu_2, mu_base=grid%mub, &
- rk_step=rk_step, dt=dt_rk, spec_zone=grid%spec_zone, &
- config_flags=config_flags, tenddec=tenddec, &
- ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, &
- ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, &
- its=grid%i_start(ij), ite=grid%i_end(ij), &
- jts=grid%j_start(ij), jte=grid%j_end(ij), &
- kts=k_start , kte=k_end )
-
- IF( config_flags%specified ) THEN
-
- IF( config_flags%perturb_chem_bdy==1 ) THEN
-
- IF(ic.eq.PARAM_FIRST_SCALAR .and. ij.eq.1) &
- CALL wrf_debug (10 , ' spec_bdy_chem_perturb' )
-
- CALL spec_bdy_chem_perturb ( config_flags%periodic_x, &
- chem_btxs(jms,kms,1,ic), chem_btxe(jms,kms,1,ic), &
- chem_btys(ims,kms,1,ic), chem_btye(ims,kms,1,ic), &
- grid%rand_pert, &
- config_flags%spec_bdy_width, grid%spec_zone, &
- grid%num_stoch_levels, & ! stoch dims
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- ips,ipe, jps,jpe, kps,kpe, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
- ENDIF
-
- CALL flow_dep_bdy_chem( chem(ims,kms,jms,ic), &
- chem_bxs(jms,kms,1,ic), chem_btxs(jms,kms,1,ic), &
- chem_bxe(jms,kms,1,ic), chem_btxe(jms,kms,1,ic), &
- chem_bys(ims,kms,1,ic), chem_btys(ims,kms,1,ic), &
- chem_bye(ims,kms,1,ic), chem_btye(ims,kms,1,ic), &
- dt_rk+grid%dtbc, &
- config_flags%spec_bdy_width,grid%z, &
- grid%have_bcs_chem, &
- grid%ru_m, grid%rv_m, config_flags,grid%alt, &
- grid%t_1,grid%pb,grid%p,t0,p1000mb,rcp,grid%ph_2,grid%phb,g, &
- grid%spec_zone,ic,grid%julday, &
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- ips,ipe, jps,jpe, kps,kpe, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end, &
- grid%u_2,grid%v_2,grid%t_2,grid%znu,grid%msft, &
- grid%msfu,grid%msfv,grid%f,grid%mub,grid%dx,grid%xlat,grid%pv)
-
- ENDIF
- ENDDO chem_tile_loop_2
- !$OMP END PARALLEL DO
-
- ENDDO chem_variable_loop
- ENDIF chem_scalar_advance
-BENCH_END(chem_adv_tim)
-#endif
-! next the chemical species
-BENCH_START(tracer_adv_tim)
- tracer_advance: IF (num_tracer >= PARAM_FIRST_SCALAR) THEN
-
- tracer_variable_loop: DO ic = PARAM_FIRST_SCALAR, num_tracer
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij, tenddec )
- tracer_tile_loop_1: DO ij = 1 , grid%num_tiles
-
- CALL wrf_debug ( 15 , ' call rk_scalar_tend in tracer_tile_loop_1' )
- tenddec = .false.
- CALL rk_scalar_tend ( ic, ic, config_flags, tenddec, &
- rk_step, dt_rk, &
- grid%ru_m, grid%rv_m, grid%ww_m, wwE, wwI, &
- grid%u_1, grid%v_1, &
- grid%muts, grid%mub, grid%mu_1, &
- grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
- grid%alt, &
- tracer_old(ims,kms,jms,ic), &
- tracer(ims,kms,jms,ic), &
- tracer_tend(ims,kms,jms,ic), &
- advect_tend,h_tendency,z_tendency,grid%rqvften, &
- grid%qv_base, .false., grid%fnm, grid%fnp, &
- grid%msfux,grid%msfuy, grid%msfvx, grid%msfvx_inv, &
- grid%msfvy, grid%msftx,grid%msfty, &
- grid%rdx, grid%rdy, grid%rdn, grid%rdnw, &
- grid%khdif, grid%kvdif, grid%xkhh, &
- grid%diff_6th_opt, grid%diff_6th_factor, &
- config_flags%tracer_adv_opt, &
- grid%phb, grid%ph_2, &
- config_flags%tracer_mix2_off, &
- config_flags%tracer_mix6_off, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-!
-! Currently, chemistry species with specified boundaries (i.e. the mother
-! domain) are being over written by flow_dep_bdy_chem. So, relax_bdy and
-! spec_bdy are only called for nests. For boundary conditions from global model or larger domain,
-! chem is uncoupled, and only used for one row/column on inflow (if have_bcs_chem=.true.)
-!
- IF( ( config_flags%nested ) .and. rk_step == 1 ) THEN
- IF(ic.eq.1)CALL wrf_debug ( 10 , ' have_bcs_tracer' )
- CALL relax_bdy_scalar ( tracer_tend(ims,kms,jms,ic), &
- tracer(ims,kms,jms,ic), grid%mut, &
- grid%c1h, grid%c2h, &
- tracer_bxs(jms,kms,1,ic),tracer_bxe(jms,kms,1,ic), &
- tracer_bys(ims,kms,1,ic),tracer_bye(ims,kms,1,ic), &
- tracer_btxs(jms,kms,1,ic),tracer_btxe(jms,kms,1,ic), &
- tracer_btys(ims,kms,1,ic),tracer_btye(ims,kms,1,ic), &
- config_flags%spec_bdy_width, grid%spec_zone, grid%relax_zone, &
- grid%dtbc, grid%fcx, grid%gcx, &
- config_flags, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- ips,ipe, jps,jpe, kps,kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
- CALL spec_bdy_scalar ( tracer_tend(ims,kms,jms,ic), &
- tracer_bxs(jms,kms,1,ic),tracer_bxe(jms,kms,1,ic), &
- tracer_bys(ims,kms,1,ic),tracer_bye(ims,kms,1,ic), &
- tracer_btxs(jms,kms,1,ic),tracer_btxe(jms,kms,1,ic), &
- tracer_btys(ims,kms,1,ic),tracer_btye(ims,kms,1,ic), &
- config_flags%spec_bdy_width, grid%spec_zone, &
- config_flags, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- ips,ipe, jps,jpe, kps,kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
- ENDIF
-
- ENDDO tracer_tile_loop_1
- !$OMP END PARALLEL DO
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij, tenddec )
-
- tracer_tile_loop_2: DO ij = 1 , grid%num_tiles
-
- CALL wrf_debug ( 200 , ' call rk_update_scalar' )
- tenddec = .false.
- CALL rk_update_scalar( scs=ic, sce=ic, &
- scalar_1=tracer_old(ims,kms,jms,ic), &
- scalar_2=tracer(ims,kms,jms,ic), &
- sc_tend=tracer_tend(ims,kms,jms,ic), &
-! advh_t=advh_t(ims,kms,jms,1), &
-! advz_t=advz_t(ims,kms,jms,1), &
- advect_tend=advect_tend, &
- h_tendency=h_tendency, z_tendency=z_tendency, &
- msftx=grid%msftx,msfty=grid%msfty, &
- c1=grid%c1h, c2=grid%c2h, &
- mu_old=grid%mu_1, mu_new=grid%mu_2, mu_base=grid%mub, &
- rk_step=rk_step, dt=dt_rk, spec_zone=grid%spec_zone, &
- config_flags=config_flags, tenddec=tenddec, &
- ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, &
- ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, &
- its=grid%i_start(ij), ite=grid%i_end(ij), &
- jts=grid%j_start(ij), jte=grid%j_end(ij), &
- kts=k_start , kte=k_end )
-
- IF( config_flags%specified ) THEN
-#if (WRF_CHEM == 1)
- CALL flow_dep_bdy_tracer( tracer(ims,kms,jms,ic), &
- tracer_bxs(jms,kms,1,ic), tracer_btxs(jms,kms,1,ic), &
- tracer_bxe(jms,kms,1,ic), tracer_btxe(jms,kms,1,ic), &
- tracer_bys(ims,kms,1,ic), tracer_btys(ims,kms,1,ic), &
- tracer_bye(ims,kms,1,ic), tracer_btye(ims,kms,1,ic), &
- dt_rk+grid%dtbc, &
- config_flags%spec_bdy_width,grid%z, &
- grid%have_bcs_tracer, &
- grid%ru_m, grid%rv_m, config_flags%tracer_opt,grid%alt, &
- grid%t_1,grid%pb,grid%p,t0,p1000mb,rcp,grid%ph_2,grid%phb,g, &
- grid%spec_zone,ic, &
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- ips,ipe, jps,jpe, kps,kpe, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
-#else
- CALL flow_dep_bdy ( tracer(ims,kms,jms,ic), &
- grid%ru_m, grid%rv_m, config_flags, &
- grid%spec_zone, &
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- ips,ipe, jps,jpe, kps,kpe, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
-#endif
- ENDIF
- ENDDO tracer_tile_loop_2
- !$OMP END PARALLEL DO
-
- ENDDO tracer_variable_loop
- ENDIF tracer_advance
-BENCH_END(tracer_adv_tim)
-
-! next the other scalar species
- other_scalar_advance: IF (num_3d_s >= PARAM_FIRST_SCALAR) THEN
-
- scalar_variable_loop: do is = PARAM_FIRST_SCALAR, num_3d_s
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij, tenddec )
- scalar_tile_loop_1: DO ij = 1 , grid%num_tiles
-
- CALL wrf_debug ( 200 , ' call rk_scalar_tend' )
- tenddec = .false.
- CALL rk_scalar_tend ( is, is, config_flags, tenddec, &
- rk_step, dt_rk, &
- grid%ru_m, grid%rv_m, grid%ww_m, wwE, wwI, &
- grid%u_1, grid%v_1, &
- grid%muts, grid%mub, grid%mu_1, &
- grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
- grid%alt, &
- scalar_old(ims,kms,jms,is), &
- scalar(ims,kms,jms,is), &
- scalar_tend(ims,kms,jms,is), &
- advect_tend,h_tendency,z_tendency,grid%rqvften, &
- grid%qv_base, .false., grid%fnm, grid%fnp, &
- grid%msfux,grid%msfuy, grid%msfvx, grid%msfvx_inv, &
- grid%msfvy, grid%msftx,grid%msfty, &
- grid%rdx, grid%rdy, grid%rdn, grid%rdnw, &
- grid%khdif, grid%kvdif, grid%xkhh, &
- grid%diff_6th_opt, grid%diff_6th_factor, &
- config_flags%scalar_adv_opt, &
- grid%phb, grid%ph_2, &
- config_flags%scalar_mix2_off, &
- config_flags%scalar_mix6_off, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- IF( rk_step == 1 ) THEN
- IF ( config_flags%nested .OR. &
- ( config_flags%specified .AND. config_flags%have_bcs_scalar ) .OR. &
- ( ( is .EQ. P_QNWFA .OR. is .EQ. P_QNIFA) .AND. config_flags%use_aero_icbc ) ) THEN
-
- CALL relax_bdy_scalar ( scalar_tend(ims,kms,jms,is), &
- scalar(ims,kms,jms,is), grid%mut, &
- grid%c1h, grid%c2h, &
- scalar_bxs(jms,kms,1,is),scalar_bxe(jms,kms,1,is), &
- scalar_bys(ims,kms,1,is),scalar_bye(ims,kms,1,is), &
- scalar_btxs(jms,kms,1,is),scalar_btxe(jms,kms,1,is), &
- scalar_btys(ims,kms,1,is),scalar_btye(ims,kms,1,is), &
- config_flags%spec_bdy_width, grid%spec_zone, grid%relax_zone, &
- grid%dtbc, grid%fcx, grid%gcx, &
- config_flags, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- ips,ipe, jps,jpe, kps,kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
-
- CALL spec_bdy_scalar ( scalar_tend(ims,kms,jms,is), &
- scalar_bxs(jms,kms,1,is),scalar_bxe(jms,kms,1,is), &
- scalar_bys(ims,kms,1,is),scalar_bye(ims,kms,1,is), &
- scalar_btxs(jms,kms,1,is),scalar_btxe(jms,kms,1,is), &
- scalar_btys(ims,kms,1,is),scalar_btye(ims,kms,1,is), &
- config_flags%spec_bdy_width, grid%spec_zone, &
- config_flags, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- ips,ipe, jps,jpe, kps,kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
-
- ENDIF
- ENDIF ! b.c test for scalars
-
- ENDDO scalar_tile_loop_1
- !$OMP END PARALLEL DO
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij, tenddec )
- scalar_tile_loop_2: DO ij = 1 , grid%num_tiles
-
- CALL wrf_debug ( 200 , ' call rk_update_scalar' )
- tenddec = .false.
- CALL rk_update_scalar( scs=is, sce=is, &
- scalar_1=scalar_old(ims,kms,jms,is), &
- scalar_2=scalar(ims,kms,jms,is), &
- sc_tend=scalar_tend(ims,kms,jms,is), &
-! advh_t=advh_t(ims,kms,jms,1), &
-! advz_t=advz_t(ims,kms,jms,1), &
- advect_tend=advect_tend, &
- h_tendency=h_tendency, z_tendency=z_tendency, &
- msftx=grid%msftx,msfty=grid%msfty, &
- c1=grid%c1h, c2=grid%c2h, &
- mu_old=grid%mu_1, mu_new=grid%mu_2, mu_base=grid%mub, &
- rk_step=rk_step, dt=dt_rk, spec_zone=grid%spec_zone, &
- config_flags=config_flags, tenddec=tenddec, &
- ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, &
- ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, &
- its=grid%i_start(ij), ite=grid%i_end(ij), &
- jts=grid%j_start(ij), jte=grid%j_end(ij), &
- kts=k_start , kte=k_end )
-
- IF ( config_flags%specified ) THEN
- IF (is.EQ.P_QDCN.OR.is.EQ.P_QTCN.OR.is.EQ.P_QNIN) THEN ! for ntu3m
- CALL flow_dep_bdy_fixed_inflow(scalar(ims,kms,jms,is), &
- grid%ru_m,grid%rv_m,config_flags,&
- grid%spec_zone,ids,ide,jds,jde, &
- kds,kde,ims,ime,jms,jme,kms,kme, &
- ips,ipe,jps,jpe,kps,kpe, &
- grid%i_start(ij),grid%i_end(ij), &
- grid%j_start(ij),grid%j_end(ij), &
- k_start,k_end)
- ELSEIF (is.EQ.P_QNN) THEN ! for ntu3m
-! IF ( is .EQ. P_QNN ) THEN ! for ntu3m
- CALL flow_dep_bdy_qnn ( scalar(ims,kms,jms,is), &
- grid%ru_m, grid%rv_m, config_flags, &
- grid%spec_zone, &
- grid%ccn_conc, & ! RAS
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- ips,ipe, jps,jpe, kps,kpe, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
- ELSE IF ( ( ( ( is .EQ. P_QNWFA ) .OR. ( is .EQ. P_QNIFA ) ) .AND. &
- ( .NOT. config_flags%use_aero_icbc ) ) &
- .OR. &
- ( ( .NOT. ( ( is .EQ. P_QNWFA ) .OR. ( is .EQ. P_QNIFA ) ) ) .AND. &
- ( .NOT. config_flags%have_bcs_scalar ) ) ) THEN
-
-! A = ( is .EQ. P_QNWFA ) .OR. ( is .EQ. P_QNIFA )
-! B = config_flags%use_aero_icbc
-! C = config_glags%have_bcs_scalar
-
-! Test| A | B | C | ( A AND NOT B ) OR ( NOT A AND NOT C )
-! ----+----+----+---+-----------------------------------------------
-! 1 | T | T | T | F = DO NOT CALL flow_dep_bdy
-! 2 | T | T | F | F = DO NOT CALL flow_dep_bdy
-! 3 | T | F | T | T = CALL flow_dep_bdy
-! 4 | T | F | F | T = CALL flow_dep_bdy
-! 5 | F | T | T | F = DO NOT CALL flow_dep_bdy
-! 6 | F | T | F | T = CALL flow_dep_bdy
-! 7 | F | F | T | F = DO NOT CALL flow_dep_bdy
-! 8 | F | F | F | T = CALL flow_dep_bdy
-! ----+----+----+---+-----------------------------------------------
-
-! If this is the special friendly fields AND are to use the aero icbc, then NO calls to flow dep: tests 1 and 2
-! If this is the special friendly fields AND do not use the aero icbc, then call flow dep: tests 3 and 4
-! If this is not the special friendly fields AND:
-! If we have bcs for scalars, do not call flow dep: tests 5 and 7
-! If we do not have bcs for scalars, call flow dep: tests 6 and 8
-
- CALL flow_dep_bdy ( scalar(ims,kms,jms,is), &
- grid%ru_m, grid%rv_m, config_flags, &
- grid%spec_zone, &
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- ips,ipe, jps,jpe, kps,kpe, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
- ENDIF
-
- ENDIF
-
- ENDDO scalar_tile_loop_2
- !$OMP END PARALLEL DO
-
- ENDDO scalar_variable_loop
-
- ENDIF other_scalar_advance
-
- ! update the pressure and density at the new time level
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
-
-BENCH_START(calc_p_rho_tim)
-
- CALL calc_p_rho_phi( moist, num_3d_m, config_flags%hypsometric_opt, &
- grid%al, grid%alb, grid%mu_2, grid%muts, &
- grid%c1h, grid%c2h, grid%c3h, grid%c4h, grid%c3f, grid%c4f, &
- grid%ph_2, grid%phb, grid%p, grid%pb, grid%t_2, &
- p0, t0, grid%p_top, grid%znu, grid%znw, grid%dnw, grid%rdnw, &
- grid%rdn, config_flags%non_hydrostatic,config_flags%use_theta_m, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
-BENCH_END(calc_p_rho_tim)
-
- ENDDO
- !$OMP END PARALLEL DO
-
-! Reset the boundary conditions if there is another corrector step.
-! (rk_step < rk_order), else we'll handle it at the end of everything
-! (after the split physics, before exiting the timestep).
-
- rk_step_1_check: IF ( rk_step < rk_order ) THEN
-
-!-----------------------------------------------------------
-! rk3 substep polar filter for scalars (moist,chem,scalar)
-!-----------------------------------------------------------
-
- IF (config_flags%polar) THEN
- IF ( num_3d_m >= PARAM_FIRST_SCALAR ) THEN
- CALL wrf_debug ( 200 , ' call filter moist ' )
- DO im = PARAM_FIRST_SCALAR, num_3d_m
- IF ( config_flags%coupled_filtering ) THEN
- CALL couple_scalars_for_filter ( FIELD=moist(ims,kms,jms,im) &
- ,MU=grid%mu_2 , MUB=grid%mub &
- ,C1=grid%c1h , C2=grid%c2h &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe )
- END IF
- CALL pxft ( grid=grid &
- ,lineno=__LINE__ &
- ,flag_uv = 0 &
- ,flag_rurv = 0 &
- ,flag_wph = 0 &
- ,flag_ww = 0 &
- ,flag_t = 0 &
- ,flag_mu = 0 &
- ,flag_mut = 0 &
- ,flag_moist = im &
- ,flag_chem = 0 &
- ,flag_scalar = 0 &
- ,flag_tracer = 0 &
- ,actual_distance_average=config_flags%actual_distance_average&
- ,pos_def = config_flags%pos_def &
- ,swap_pole_with_next_j = config_flags%swap_pole_with_next_j &
- ,moist=moist,chem=chem,tracer=tracer,scalar=scalar &
- ,fft_filter_lat = config_flags%fft_filter_lat &
- ,dclat = dclat &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe &
- ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
- ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
- IF ( config_flags%coupled_filtering ) THEN
- CALL uncouple_scalars_for_filter ( FIELD=moist(ims,kms,jms,im) &
- ,MU=grid%mu_2 , MUB=grid%mub &
- ,C1=grid%c1h , C2=grid%c2h &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe )
- END IF
- END DO
- END IF
-
- IF ( num_3d_c >= PARAM_FIRST_SCALAR ) THEN
- CALL wrf_debug ( 200 , ' call filter chem ' )
- DO im = PARAM_FIRST_SCALAR, num_3d_c
- IF ( config_flags%coupled_filtering ) THEN
- CALL couple_scalars_for_filter ( FIELD=chem(ims,kms,jms,im) &
- ,MU=grid%mu_2 , MUB=grid%mub &
- ,C1=grid%c1h , C2=grid%c2h &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe )
- END IF
- CALL pxft ( grid=grid &
- ,lineno=__LINE__ &
- ,flag_uv = 0 &
- ,flag_rurv = 0 &
- ,flag_wph = 0 &
- ,flag_ww = 0 &
- ,flag_t = 0 &
- ,flag_mu = 0 &
- ,flag_mut = 0 &
- ,flag_moist = 0 &
- ,flag_chem = im &
- ,flag_tracer = 0 &
- ,flag_scalar = 0 &
- ,actual_distance_average=config_flags%actual_distance_average&
- ,pos_def = config_flags%pos_def &
- ,swap_pole_with_next_j = config_flags%swap_pole_with_next_j &
- ,moist=moist,chem=chem,tracer=tracer,scalar=scalar &
- ,fft_filter_lat = config_flags%fft_filter_lat &
- ,dclat = dclat &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe &
- ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
- ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
- IF ( config_flags%coupled_filtering ) THEN
- CALL uncouple_scalars_for_filter ( FIELD=chem(ims,kms,jms,im) &
- ,MU=grid%mu_2 , MUB=grid%mub &
- ,C1=grid%c1h , C2=grid%c2h &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe )
- END IF
- END DO
- END IF
- IF ( num_tracer >= PARAM_FIRST_SCALAR ) THEN
- CALL wrf_debug ( 200 , ' call filter tracer ' )
- DO im = PARAM_FIRST_SCALAR, num_tracer
- IF ( config_flags%coupled_filtering ) THEN
- CALL couple_scalars_for_filter ( FIELD=tracer(ims,kms,jms,im) &
- ,MU=grid%mu_2 , MUB=grid%mub &
- ,C1=grid%c1h , C2=grid%c2h &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe )
- END IF
- CALL pxft ( grid=grid &
- ,lineno=__LINE__ &
- ,flag_uv = 0 &
- ,flag_rurv = 0 &
- ,flag_wph = 0 &
- ,flag_ww = 0 &
- ,flag_t = 0 &
- ,flag_mu = 0 &
- ,flag_mut = 0 &
- ,flag_moist = 0 &
- ,flag_chem = 0 &
- ,flag_tracer = im &
- ,flag_scalar = 0 &
- ,actual_distance_average=config_flags%actual_distance_average&
- ,pos_def = config_flags%pos_def &
- ,swap_pole_with_next_j = config_flags%swap_pole_with_next_j &
- ,moist=moist,chem=chem,tracer=tracer,scalar=scalar &
- ,fft_filter_lat = config_flags%fft_filter_lat &
- ,dclat = dclat &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe &
- ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
- ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
- IF ( config_flags%coupled_filtering ) THEN
- CALL uncouple_scalars_for_filter ( FIELD=tracer(ims,kms,jms,im) &
- ,MU=grid%mu_2 , MUB=grid%mub &
- ,C1=grid%c1h , C2=grid%c2h &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe )
- END IF
- END DO
- END IF
-
- IF ( num_3d_s >= PARAM_FIRST_SCALAR ) THEN
- CALL wrf_debug ( 200 , ' call filter scalar ' )
- DO im = PARAM_FIRST_SCALAR, num_3d_s
- IF ( config_flags%coupled_filtering ) THEN
- CALL couple_scalars_for_filter ( FIELD=scalar(ims,kms,jms,im) &
- ,MU=grid%mu_2 , MUB=grid%mub &
- ,C1=grid%c1h , C2=grid%c2h &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe )
- END IF
- CALL pxft ( grid=grid &
- ,lineno=__LINE__ &
- ,flag_uv = 0 &
- ,flag_rurv = 0 &
- ,flag_wph = 0 &
- ,flag_ww = 0 &
- ,flag_t = 0 &
- ,flag_mu = 0 &
- ,flag_mut = 0 &
- ,flag_moist = 0 &
- ,flag_chem = 0 &
- ,flag_tracer = 0 &
- ,flag_scalar = im &
- ,actual_distance_average=config_flags%actual_distance_average&
- ,pos_def = config_flags%pos_def &
- ,swap_pole_with_next_j = config_flags%swap_pole_with_next_j &
- ,moist=moist,chem=chem,tracer=tracer,scalar=scalar &
- ,fft_filter_lat = config_flags%fft_filter_lat &
- ,dclat = dclat &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe &
- ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
- ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
- IF ( config_flags%coupled_filtering ) THEN
- CALL uncouple_scalars_for_filter ( FIELD=scalar(ims,kms,jms,im) &
- ,MU=grid%mu_2 , MUB=grid%mub &
- ,C1=grid%c1h , C2=grid%c2h &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe )
- END IF
- END DO
- END IF
- END IF ! polar filter test
-
-!-----------------------------------------------------------
-! END rk3 substep polar filter for scalars (moist,chem,scalar)
-!-----------------------------------------------------------
-
-!-----------------------------------------------------------
-! Stencils for patch communications (WCS, 29 June 2001)
-!
-! here's where we need a wide comm stencil - these are the
-! uncoupled variables so are used for high order calc in
-! advection and mixong routines.
-!
-!
-! * * * * * * *
-! * * * * * * * * * * * *
-! * * * * * * * * * * * * *
-! * + * * * + * * * * * + * * *
-! * * * * * * * * * * * * *
-! * * * * * * * * * * * *
-! * * * * * * *
-!
-! al x
-!
-! 2D variable
-! mu_2 x
-!
-! (adv order <=4)
-! u_2 x
-! v_2 x
-! w_2 x
-! t_2 x
-! ph_2 x
-!
-! (adv order <=6)
-! u_2 x
-! v_2 x
-! w_2 x
-! t_2 x
-! ph_2 x
-!
-! 4D variable
-! moist x
-! chem x
-! scalar x
-
-#ifdef DM_PARALLEL
- IF ( config_flags%h_mom_adv_order <= 4 .and. config_flags%h_sca_adv_order <= 4 ) THEN
-# include "HALO_EM_D2_3.inc"
- ELSE IF ( config_flags%h_mom_adv_order <= 6 .and. config_flags%h_sca_adv_order <= 6 ) THEN
-# include "HALO_EM_D2_5.inc"
- ELSE
- WRITE(wrf_err_message,*)'solve_em: invalid h_mom_adv_order or h_sca_adv_order = ', &
- config_flags%h_mom_adv_order, config_flags%h_sca_adv_order
- CALL wrf_error_fatal(TRIM(wrf_err_message))
- ENDIF
-# include "PERIOD_BDY_EM_D.inc"
-# include "PERIOD_BDY_EM_MOIST2.inc"
-# include "PERIOD_BDY_EM_CHEM2.inc"
-# include "PERIOD_BDY_EM_TRACER2.inc"
-# include "PERIOD_BDY_EM_SCALAR2.inc"
-# include "PERIOD_BDY_EM_TKE.inc"
-#endif
-
-BENCH_START(bc_end_tim)
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- tile_bc_loop_1: DO ij = 1 , grid%num_tiles
- CALL wrf_debug ( 200 , ' call rk_phys_bc_dry_2' )
-
- CALL rk_phys_bc_dry_2( config_flags, &
- grid%u_2, grid%v_2, grid%w_2, &
- grid%t_2, grid%ph_2, grid%mu_2, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
-BENCH_START(diag_w_tim)
- IF (.not. config_flags%non_hydrostatic) THEN
- CALL diagnose_w( ph_tend, grid%ph_2, grid%ph_1, grid%w_2, grid%muts, &
- grid%c1f, grid%c2f, dt_rk, &
- grid%u_2, grid%v_2, grid%ht, &
- grid%cf1, grid%cf2, grid%cf3, grid%rdx, grid%rdy, grid%msftx, grid%msfty, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- ENDIF
-BENCH_END(diag_w_tim)
-
- IF (num_3d_m >= PARAM_FIRST_SCALAR) THEN
-
- moisture_loop_bdy_1 : DO im = PARAM_FIRST_SCALAR , num_3d_m
-
- CALL set_physical_bc3d( moist(ims,kms,jms,im), 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- END DO moisture_loop_bdy_1
-
- ENDIF
-
- IF (num_3d_c >= PARAM_FIRST_SCALAR) THEN
-
- chem_species_bdy_loop_1 : DO ic = PARAM_FIRST_SCALAR , num_3d_c
-
- CALL set_physical_bc3d( chem(ims,kms,jms,ic), 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end-1 )
-
- END DO chem_species_bdy_loop_1
-
- END IF
-
- IF (num_tracer >= PARAM_FIRST_SCALAR) THEN
-
- tracer_species_bdy_loop_1 : DO ic = PARAM_FIRST_SCALAR , num_tracer
-
- CALL set_physical_bc3d( tracer(ims,kms,jms,ic), 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end-1 )
-
- END DO tracer_species_bdy_loop_1
-
- END IF
-
- IF (num_3d_s >= PARAM_FIRST_SCALAR) THEN
-
- scalar_species_bdy_loop_1 : DO is = PARAM_FIRST_SCALAR , num_3d_s
-
- CALL set_physical_bc3d( scalar(ims,kms,jms,is), 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end-1 )
-
- END DO scalar_species_bdy_loop_1
-
- END IF
-
- IF (config_flags%km_opt .eq. 2) THEN
-
- CALL set_physical_bc3d( grid%tke_2 , 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- END IF
-
- END DO tile_bc_loop_1
- !$OMP END PARALLEL DO
-BENCH_END(bc_end_tim)
-
-
-#ifdef DM_PARALLEL
-
-! * * * * *
-! * * * * * * * * *
-! * + * * + * * * + * *
-! * * * * * * * * *
-! * * * * *
-
-! moist, chem, scalar, tke x
-
-
- IF ( config_flags%h_sca_adv_order <= 4 ) THEN
- IF ( (config_flags%tke_adv_opt /= ORIGINAL .and. config_flags%tke_adv_opt /= WENO_SCALAR) .and. (rk_step == rk_order-1) ) THEN
-# include "HALO_EM_TKE_5.inc"
- ELSE
-# include "HALO_EM_TKE_3.inc"
- ENDIF
- ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
- IF ( (config_flags%tke_adv_opt /= ORIGINAL .and. config_flags%tke_adv_opt /= WENO_SCALAR) .and. (rk_step == rk_order-1) ) THEN
-# include "HALO_EM_TKE_7.inc"
- ELSE
-# include "HALO_EM_TKE_5.inc"
- ENDIF
- ELSE
- WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
- CALL wrf_error_fatal(TRIM(wrf_err_message))
- ENDIF
-
- IF ( num_moist .GE. PARAM_FIRST_SCALAR ) THEN
- IF ( config_flags%h_sca_adv_order <= 4 ) THEN
- IF ( (config_flags%moist_adv_opt /= ORIGINAL .and. config_flags%moist_adv_opt /= WENO_SCALAR) .and. (rk_step == rk_order-1) ) THEN
-# include "HALO_EM_MOIST_E_5.inc"
- ELSE
-# include "HALO_EM_MOIST_E_3.inc"
- END IF
- ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
- IF ( (config_flags%moist_adv_opt /= ORIGINAL .and. config_flags%moist_adv_opt /= WENO_SCALAR) .and. (rk_step == rk_order-1) ) THEN
-# include "HALO_EM_MOIST_E_7.inc"
- ELSE
-# include "HALO_EM_MOIST_E_5.inc"
- END IF
- ELSE
- WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
- CALL wrf_error_fatal(TRIM(wrf_err_message))
- ENDIF
- ENDIF
- IF ( num_chem >= PARAM_FIRST_SCALAR ) THEN
- IF ( config_flags%h_sca_adv_order <= 4 ) THEN
- IF ( (config_flags%chem_adv_opt /= ORIGINAL .and. config_flags%chem_adv_opt /= WENO_SCALAR) .and. (rk_step == rk_order-1) ) THEN
-# include "HALO_EM_CHEM_E_5.inc"
- ELSE
-# include "HALO_EM_CHEM_E_3.inc"
- ENDIF
- ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
- IF ( (config_flags%chem_adv_opt /= ORIGINAL .and. config_flags%chem_adv_opt /= WENO_SCALAR) .and. (rk_step == rk_order-1) ) THEN
-# include "HALO_EM_CHEM_E_7.inc"
- ELSE
-# include "HALO_EM_CHEM_E_5.inc"
- ENDIF
- ELSE
- WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
- CALL wrf_error_fatal(TRIM(wrf_err_message))
- ENDIF
- ENDIF
- IF ( num_tracer >= PARAM_FIRST_SCALAR ) THEN
- IF ( config_flags%h_sca_adv_order <= 4 ) THEN
- IF ( (config_flags%tracer_adv_opt /= ORIGINAL .and. config_flags%tracer_adv_opt /= WENO_SCALAR) .and. (rk_step == rk_order-1) ) THEN
-# include "HALO_EM_TRACER_E_5.inc"
- ELSE
-# include "HALO_EM_TRACER_E_3.inc"
- ENDIF
- ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
- IF ( (config_flags%tracer_adv_opt /= ORIGINAL .and. config_flags%tracer_adv_opt /= WENO_SCALAR) .and. (rk_step == rk_order-1) ) THEN
-# include "HALO_EM_TRACER_E_7.inc"
- ELSE
-# include "HALO_EM_TRACER_E_5.inc"
- ENDIF
- ELSE
- WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
- CALL wrf_error_fatal(TRIM(wrf_err_message))
- ENDIF
- ENDIF
- IF ( num_scalar >= PARAM_FIRST_SCALAR ) THEN
- IF ( config_flags%h_sca_adv_order <= 4 ) THEN
- IF ( (config_flags%scalar_adv_opt /= ORIGINAL .and. config_flags%scalar_adv_opt /= WENO_SCALAR) .and. (rk_step == rk_order-1) ) THEN
-# include "HALO_EM_SCALAR_E_5.inc"
- ELSE
-# include "HALO_EM_SCALAR_E_3.inc"
- ENDIF
- ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
- IF ( (config_flags%scalar_adv_opt /= ORIGINAL .and. config_flags%scalar_adv_opt /= WENO_SCALAR) .and. (rk_step == rk_order-1) ) THEN
-# include "HALO_EM_SCALAR_E_7.inc"
- ELSE
-# include "HALO_EM_SCALAR_E_5.inc"
- ENDIF
- ELSE
- WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
- CALL wrf_error_fatal(TRIM(wrf_err_message))
- ENDIF
- ENDIF
-#endif
-
- ENDIF rk_step_1_check
-
-
-!**********************************************************
-!
-! end of RK predictor-corrector loop
-!
-!**********************************************************
-
- END DO Runge_Kutta_loop
-! grid%dmudt=grid%mu_2 - grid%mu_1
-
-#if ( WRFPLUS != 1 )
- IF ( config_flags%traj_opt .EQ. UM_TRAJECTORY ) THEN
-#ifdef DM_PARALLEL
-# include "HALO_EM_F_1.inc"
-# include "HALO_EM_D.inc"
-# include "HALO_EM_INIT_4.inc"
- IF( config_flags%periodic_x ) THEN
-# include "PERIOD_EM_DA.inc"
-# include "PERIOD_EM_F.inc"
-# include "PERIOD_EM_G.inc"
- ENDIF
-#endif
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
-
- call trajectory (grid,config_flags, &
- grid%dt,grid%itimestep,grid%ru_m, grid%rv_m, grid%ww_m,&
- grid%muts,grid%muus,grid%muvs, &
- grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
- grid%rdx, grid%rdy, grid%rdn, grid%rdnw,grid%rdzw, &
- grid%traj_i,grid%traj_j,grid%traj_k, &
- grid%traj_long,grid%traj_lat, &
- grid%xlong,grid%xlat, &
- grid%msftx,grid%msfux,grid%msfvy, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- ENDDO
- !$OMP END PARALLEL DO
- ENDIF
-#endif
-!-----------------------------------------------------------
-
- IF (config_flags%do_avgflx_em .EQ. 1) THEN
-! Reinitialize time-averaged fluxes if history output was written after the previous time step:
- CALL WRFU_ALARMGET(grid%alarms( HISTORY_ALARM ),prevringtime=temp_time)
- CALL domain_clock_get ( grid, current_time=CurrTime, &
- current_timestr=message2 )
-! use overloaded -, .LT. operator to check whether to initialize avgflx:
-! reinitialize after each history output (detect this here by comparing current time
-! against last history time and time step - this code follows what's done in adapt_timestep_em):
- WRITE ( message , FMT = '("solve_em: old_dt =",g15.6,", dt=",g15.6," on domain ",I3)' ) &
- & old_dt,grid%dt,grid%id
- CALL wrf_debug(200,message)
- old_dt=min(old_dt,grid%dt)
- num = INT(old_dt * precision)
- den = precision
- CALL WRFU_TimeIntervalSet(dtInterval, Sn=num, Sd=den)
- IF (CurrTime .lt. temp_time + dtInterval) THEN
- WRITE ( message , FMT = '("solve_em: initializing avgflx at time ",A," on domain ",I3)' ) &
- & TRIM(message2), grid%id
- CALL wrf_message(trim(message))
- grid%avgflx_count = 0
-!tile-loop for zero_avgflx
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
-
- DO ij = 1 , grid%num_tiles
- CALL wrf_debug(200,'In solve_em, before zero_avgflx call')
- CALL zero_avgflx(grid%avgflx_rum,grid%avgflx_rvm,grid%avgflx_wwm, &
- & ids, ide, jds, jde, kds, kde, &
- & ims, ime, jms, jme, kms, kme, &
- & grid%i_start(ij), grid%i_end(ij), grid%j_start(ij), grid%j_end(ij), &
- & k_start , k_end, f_flux, &
- & grid%avgflx_cfu1,grid%avgflx_cfd1,grid%avgflx_dfu1, &
- & grid%avgflx_efu1,grid%avgflx_dfd1,grid%avgflx_efd1 )
- CALL wrf_debug(200,'In solve_em, after zero_avgflx call')
- ENDDO
- !$OMP END PARALLEL DO
- ENDIF
-
-! Update avgflx quantities
-!tile-loop for upd_avgflx
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
-
- DO ij = 1 , grid%num_tiles
- CALL wrf_debug(200,'In solve_em, before upd_avgflx call')
- CALL upd_avgflx(grid%avgflx_count,grid%avgflx_rum,grid%avgflx_rvm,grid%avgflx_wwm, &
- & grid%ru_m, grid%rv_m, grid%ww_m, &
- & ids, ide, jds, jde, kds, kde, &
- & ims, ime, jms, jme, kms, kme, &
- & grid%i_start(ij), grid%i_end(ij), grid%j_start(ij), grid%j_end(ij), &
- & k_start , k_end, f_flux, &
- & grid%cfu1,grid%cfd1,grid%dfu1,grid%efu1,grid%dfd1,grid%efd1, &
- & grid%avgflx_cfu1,grid%avgflx_cfd1,grid%avgflx_dfu1, &
- & grid%avgflx_efu1,grid%avgflx_dfd1,grid%avgflx_efd1 )
- CALL wrf_debug(200,'In solve_em, after upd_avgflx call')
-
- ENDDO
- !$OMP END PARALLEL DO
- grid%avgflx_count = grid%avgflx_count + 1
- ENDIF
-!
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
-
-BENCH_START(advance_ppt_tim)
- CALL wrf_debug ( 200 , ' call advance_ppt' )
- CALL advance_ppt(grid%rthcuten,grid%rqvcuten,grid%rqccuten,grid%rqrcuten, &
- grid%cldfra_cup, & !BSINGH - Added for CuP scheme
- grid%rqicuten,grid%rqscuten, &
- grid%rainc,grid%raincv,grid%rainsh,grid%pratec,grid%pratesh, &
- grid%nca,grid%htop,grid%hbot,grid%cutop,grid%cubot, &
- grid%cuppt, grid%dt, config_flags, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-BENCH_END(advance_ppt_tim)
-
- ENDDO
- !$OMP END PARALLEL DO
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
- CALL wrf_debug ( 200 , ' call phy_prep_part2' )
- CALL phy_prep_part2 ( config_flags, &
- grid%muts, grid%muus, grid%muvs, &
- grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
- grid%rthraten, &
- grid%rthblten, grid%rublten, grid%rvblten, &
- grid%rqvblten, grid%rqcblten, grid%rqiblten, &
- grid%rucuten, grid%rvcuten, grid%rthcuten, &
- grid%rqvcuten, grid%rqccuten, grid%rqrcuten, &
- grid%rqicuten, grid%rqscuten, &
- grid%rushten, grid%rvshten, grid%rthshten, &
- grid%rqvshten, grid%rqcshten, grid%rqrshten, &
- grid%rqishten, grid%rqsshten, grid%rqgshten, &
- grid%rthften, grid%rqvften, &
- grid%RUNDGDTEN, grid%RVNDGDTEN, grid%RTHNDGDTEN, &
- grid%RPHNDGDTEN,grid%RQVNDGDTEN, grid%RMUNDGDTEN,&
- grid%t_2, th_phy, moist(ims,kms,jms,P_QV), &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
- ENDDO
- !$OMP END PARALLEL DO
-
-!
-!
-! (5) time-split physics.
-!
-! Microphysics are the only time split physics in the WRF model
-! at this time. Split-physics begins with the calculation of
-! needed diagnostic quantities (pressure, temperature, etc.)
-! followed by a call to the microphysics driver,
-! and finishes with a clean-up, storing off of a diabatic tendency
-! from the moist physics, and a re-calulation of the diagnostic
-! quantities pressure and density.
-!
-!
-
- IF( config_flags%specified .or. config_flags%nested ) THEN
- sz = grid%spec_zone
- ELSE
- sz = 0
- ENDIF
-
- IF (config_flags%mp_physics /= 0) then
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij, its, ite, jts, jte )
-
- scalar_tile_loop_1a: DO ij = 1 , grid%num_tiles
-
- IF ( config_flags%periodic_x ) THEN
- its = max(grid%i_start(ij),ids)
- ite = min(grid%i_end(ij),ide-1)
- ELSE
- its = max(grid%i_start(ij),ids+sz)
- ite = min(grid%i_end(ij),ide-1-sz)
- ENDIF
- jts = max(grid%j_start(ij),jds+sz)
- jte = min(grid%j_end(ij),jde-1-sz)
-
- if (config_flags%madwrf_opt == 2) then
- CALL wrf_debug ( 200 , ' call cloud_tracer_nudge' )
-
- CALL cloud_tracer_nudge( dtm, config_flags%madwrf_dt_relax, &
- config_flags%madwrf_dt_nudge, &
- grid%xtime, &
- moist(ims,kms,jms,P_QC), &
- moist(ims,kms,jms,P_QI), &
- moist(ims,kms,jms,P_QS), &
- tracer(ims,kms,jms,P_tr_qc), &
- tracer(ims,kms,jms,P_tr_qi), &
- tracer(ims,kms,jms,P_tr_qs), &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, &
- k_start , k_end )
- end if
-
- CALL wrf_debug ( 200 , ' call moist_physics_prep' )
-BENCH_START(moist_physics_prep_tim)
- CALL moist_physics_prep_em( grid%t_2, grid%t_1, t0, grid%rho, &
- grid%al, grid%alb, grid%p, p8w, p0, grid%pb, &
- grid%ph_2, grid%phb, th_phy, pi_phy , p_phy, &
- grid%z, grid%z_at_w, dz8w, &
- dtm, grid%h_diabatic, &
- moist(ims,kms,jms,P_QV),grid%qv_diabatic, &
- moist(ims,kms,jms,P_QC),grid%qc_diabatic, &
- config_flags,grid%fnm, grid%fnp, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, &
- k_start , k_end )
-
- IF (config_flags%dust_emis.eq.1 .AND. config_flags%mp_physics.eq.thompsonaero) then
- CALL wrf_debug ( 200 , ' call bulk_dust_emis' )
- CALL bulk_dust_emis (grid%itimestep,dtm,config_flags%num_soil_layers &
- ,grid%u_phy,grid%v_phy,grid%rho,grid%alt &
- ,grid%u10,grid%v10,p8w,dz8w,grid%smois,grid%erod &
- ,grid%ivgtyp,grid%isltyp,grid%vegfra,grid%albbck,grid%xland &
- ,grid%dx, g, grid%qnifa2d, ids,ide, jds,jde, kds,kde &
- ,ims,ime, jms,jme, kms,kme &
- ,its,ite, jts,jte, k_start,k_end )
- ENDIF
-
-BENCH_END(moist_physics_prep_tim)
- END DO scalar_tile_loop_1a
- !$OMP END PARALLEL DO
-
- CALL wrf_debug ( 200 , ' call microphysics_driver' )
-
- grid%sr = 0.
- specified_bdy = config_flags%specified .OR. config_flags%nested
- channel_bdy = config_flags%specified .AND. config_flags%periodic_x
-
-BENCH_START(micro_driver_tim)
-
-!
-! WRFU_AlarmIsRinging always returned false, so using an alternate method to find out if it is time
-! to dump history/restart files so microphysics can be told to calculate things like radar reflectivity.
-!
-! diagflag = .false.
-! CALL WRFU_ALARMGET(grid%alarms( HISTORY_ALARM ),prevringtime=temp_time,RingInterval=intervaltime)
-! CALL WRFU_ALARMGET(grid%alarms( RESTART_ALARM ),prevringtime=restart_time,RingInterval=restartinterval)
-! CALL domain_clock_get ( grid, current_time=CurrTime )
-! old_dt=min(old_dt,grid%dt)
-! num = INT(old_dt * precision)
-! den = precision
-! CALL WRFU_TimeIntervalSet(dtInterval, Sn=num, Sd=den)
-! IF (CurrTime .ge. temp_time + intervaltime - dtInterval .or. &
-! CurrTime .ge. restart_time + restartinterval - dtInterval ) THEN
-! diagflag = .true.
-! ENDIF
-! WRITE(wrf_err_message,*)'diag_flag=',diag_flag
-! CALL wrf_debug ( 0 , wrf_err_message )
-#ifdef DM_PARALLEL
-# include "HALO_EM_SBM.inc"
-#endif
-
-
- CALL microphysics_driver( &
- & DT=dtm ,DX=grid%dx ,DY=grid%dy &
- & ,DZ8W=dz8w ,F_ICE_PHY=grid%f_ice_phy &
- & ,ITIMESTEP=grid%itimestep ,LOWLYR=grid%lowlyr &
- & ,P8W=p8w ,P=p_phy ,PI_PHY=pi_phy &
- & ,RHO=grid%rho ,SPEC_ZONE=grid%spec_zone &
- & ,SR=grid%sr ,TH=th_phy &
- & ,refl_10cm=grid%refl_10cm & ! hm, 9/22/09 for refl
- & ,vmi3d=grid%vmi3d & ! for P3
- & ,di3d=grid%di3d & ! for P3
- & ,rhopo3d=grid%rhopo3d & ! for P3
- & ,phii3d=grid%phii3d & ! for Jensen ISHMAEL
- & ,vmi3d_2=grid%vmi3d_2 & ! for P3
- & ,di3d_2=grid%di3d_2 & ! for P3
- & ,rhopo3d_2=grid%rhopo3d_2 & ! for P3
- & ,phii3d_2=grid%phii3d_2 & ! for Jensen ISHMAEL
- & ,vmi3d_3=grid%vmi3d_3 & ! for Jensen ISHMAEL
- & ,di3d_3=grid%di3d_3 & ! for Jensen ISHMAEL
- & ,rhopo3d_3=grid%rhopo3d_3 & ! for Jensen ISHMAEL
- & ,phii3d_3=grid%phii3d_3 & ! for Jensen ISHMAEL
- & ,itype=grid%itype & ! for Jensen ISHMAEL
- & ,itype_2=grid%itype_2 & ! for Jensen ISHMAEL
- & ,itype_3=grid%itype_3 & ! for Jensen ISHMAEL
- & ,WARM_RAIN=grid%warm_rain &
- & ,T8W=t8w &
- & ,CLDFRA=grid%cldfra, EXCH_H=grid%exch_h &
- & ,NSOURCE=grid%qndropsource &
-#if (WRF_CHEM == 1)
- & ,QLSINK=grid%qlsink,CLDFRA_OLD=grid%cldfra_old &
- & ,PRECR=grid%precr, PRECI=grid%preci, PRECS=grid%precs, PRECG=grid%precg &
- & ,CHEM_OPT=config_flags%chem_opt, PROGN=config_flags%progn &
-!======================
- ! Variables required for CAMMGMP Scheme when run with WRF_CHEM
- & ,CHEM=chem &
- & ,QME3D=grid%qme3d,PRAIN3D=grid%prain3d &
- & ,NEVAPR3D=grid%nevapr3d &
- & ,RATE1ORD_CW2PR_ST3D=grid%rate1ord_cw2pr_st3d &
- & ,DGNUM4D=grid%dgnum4d,DGNUMWET4D=grid%dgnumwet4d &
-!======================
-#endif
- & ,XLAND=grid%xland,SNOWH=grid%SNOW & !PMA
- & ,SPECIFIED=specified_bdy, CHANNEL_SWITCH=channel_bdy &
- & ,F_RAIN_PHY=grid%f_rain_phy &
- & ,F_RIMEF_PHY=grid%f_rimef_phy &
- & ,MP_PHYSICS=config_flags%mp_physics &
- & ,ID=grid%id &
- & ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &
- & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
- & ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe &
- & ,I_START=grid%i_start,I_END=min(grid%i_end, ide-1) &
- & ,J_START=grid%j_start,J_END=min(grid%j_end, jde-1) &
- & ,KTS=k_start, KTE=min(k_end,kde-1) &
- & ,NUM_TILES=grid%num_tiles &
- & ,NAER=grid%naer &
-!===================== IRRIGATION =========================
- & ,IRRIGATION=grid%irrigation &
- & ,SF_SURF_IRR_SCHEME=config_flags%sf_surf_irr_scheme &
- & ,IRR_DAILY_AMOUNT=config_flags%irr_daily_amount &
- & ,IRR_START_HOUR=config_flags%irr_start_hour &
- & ,IRR_NUM_HOURS=config_flags%irr_num_hours &
- & ,JULIAN_IN=grid%julian &
- & ,IRR_START_JULIANDAY=config_flags%irr_start_julianday &
- & ,IRR_END_JULIANDAY=config_flags%irr_end_julianday &
- & ,IRR_FREQ=config_flags%irr_freq,IRR_PH=config_flags%irr_ph &
- & ,IRR_RAND_FIELD=grid%irr_rand_field &
- & ,GMT=grid%gmt,XTIME=grid%xtime &
-!======================
- ! Variables required for CAMMGMP Scheme
- & ,DLF=grid%dlf,DLF2=grid%dlf2,T_PHY=grid%t_phy,P_HYD=grid%p_hyd &
- & ,P8W_HYD=grid%p_hyd_w,TKE_PBL=grid%tke_pbl &
- & ,Z_AT_W=grid%z_at_w,QFX=grid%qfx,RLIQ=grid%rliq &
- & ,TURBTYPE3D=grid%turbtype3d,SMAW3D=grid%smaw3d &
- & ,WSEDL3D=grid%wsedl3d,CLDFRA_OLD_MP=grid%cldfra_old_mp &
- & ,CLDFRA_MP=grid%cldfra_mp,CLDFRA_MP_ALL=grid%cldfra_mp_ALL &
- & ,LRADIUS=grid%LRADIUS, IRADIUS=grid%IRADIUS & !BSINGH(01/20/2014): Added for RRTMG<->CAMMGMP
- & ,CLDFRAI=grid%cldfrai &
- & ,CLDFRAL=grid%cldfral,CLDFRA_CONV=grid%CLDFRA_CONV &
- & ,ALT=grid%alt &
- & ,ACCUM_MODE=config_flags%accum_mode &
- & ,AITKEN_MODE=config_flags%aitken_mode &
- & ,COARSE_MODE=config_flags%coarse_mode &
- & ,ICWMRSH3D=grid%icwmrsh,ICWMRDP3D=grid%icwmrdp3d &
- & ,SHFRC3D=grid%shfrc3d,CMFMC3D=grid%cmfmc &
- & ,CMFMC2_3D=grid%cmfmc2,CONFIG_FLAGS=config_flags &
- & ,FNM=grid%fnm,FNP=grid%fnp,RH_OLD_MP=grid%rh_old_mp &
- & ,LCD_OLD_MP=grid%lcd_old_mp &
-!======================
- ! Optional
- & , RAINNC=grid%rainnc, RAINNCV=grid%rainncv &
- & , SNOWNC=grid%snownc, SNOWNCV=grid%snowncv &
- & , GRAUPELNC=grid%graupelnc, GRAUPELNCV=grid%graupelncv & ! for milbrandt2mom
- & , HAILNC=grid%hailnc, HAILNCV=grid%hailncv &
- & , W=grid%w_2, Z=grid%z, HT=grid%ht &
- & , MP_RESTART_STATE=grid%mp_restart_state &
- & , TBPVS_STATE=grid%tbpvs_state & ! etampnew
- & , TBPVS0_STATE=grid%tbpvs0_state & ! etampnew
- & , QV_CURR=moist(ims,kms,jms,P_QV), F_QV=F_QV &
- & , QC_CURR=moist(ims,kms,jms,P_QC), F_QC=F_QC &
- & , QR_CURR=moist(ims,kms,jms,P_QR), F_QR=F_QR &
- & , QI_CURR=moist(ims,kms,jms,P_QI), F_QI=F_QI &
- & , QS_CURR=moist(ims,kms,jms,P_QS), F_QS=F_QS &
- & , QG_CURR=moist(ims,kms,jms,P_QG), F_QG=F_QG &
- & , QH_CURR=moist(ims,kms,jms,P_QH), F_QH=F_QH & ! for milbrandt2mom
- & , QIC_CURR=moist(ims,kms,jms,P_QIC), F_QIC=F_QIC &
- & , QIP_CURR=moist(ims,kms,jms,P_QIP), F_QIP=F_QIP &
- & , QID_CURR=moist(ims,kms,jms,P_QID), F_QID=F_QID &
- & , QNDROP_CURR=scalar(ims,kms,jms,P_QNDROP), F_QNDROP=F_QNDROP &
-#if (WRF_CHEM == 1)
- & , RAINPROD=wetscav_frcing(ims,kms,jms,p_rainprod) &
- & , EVAPPROD=wetscav_frcing(ims,kms,jms,p_evapprod) &
- & , QV_B4MP=grid%qv_b4mp,QC_B4MP=grid%qc_b4mp &
- & , QI_B4MP=grid%qi_b4mp, QS_B4MP=grid%qs_b4mp &
-#endif
- & , QT_CURR=scalar(ims,kms,jms,P_QT), F_QT=F_QT &
- & , QNN_CURR=scalar(ims,kms,jms,P_QNN), F_QNN=F_QNN &
- & , QNI_CURR=scalar(ims,kms,jms,P_QNI), F_QNI=F_QNI &
- & , QNC_CURR=scalar(ims,kms,jms,P_QNC), F_QNC=F_QNC &
- & , QNR_CURR=scalar(ims,kms,jms,P_QNR), F_QNR=F_QNR &
- & , QNS_CURR=scalar(ims,kms,jms,P_QNS), F_QNS=F_QNS &
- & , QNG_CURR=scalar(ims,kms,jms,P_QNG), F_QNG=F_QNG &
- & , QNWFA_CURR=scalar(ims,kms,jms,P_QNWFA), F_QNWFA=F_QNWFA & ! for Thompson water-friendly aerosol
- & , QNIFA_CURR=scalar(ims,kms,jms,P_QNIFA), F_QNIFA=F_QNIFA & ! for Thompson ice-friendly aerosol
- & , QNH_CURR=scalar(ims,kms,jms,P_QNH), F_QNH=F_QNH & ! for milbrandt2mom and nssl_2mom
- & , QNIC_CURR=scalar(ims,kms,jms,P_QNIC), F_QNIC=F_QNIC &
- & , QNIP_CURR=scalar(ims,kms,jms,P_QNIP), F_QNIP=F_QNIP &
- & , QNID_CURR=scalar(ims,kms,jms,P_QNID), F_QNID=F_QNID &
- & , QIR_CURR=scalar(ims,kms,jms,P_QIR), F_QIR=F_QIR & ! for P3
- & , QIB_CURR=scalar(ims,kms,jms,P_QIB), F_QIB=F_QIB & ! for P3
- & , QVOLI_CURR=scalar(ims,kms,jms,P_QVOLI), F_QVOLI=F_QVOLI & ! for Jensen ISHMAEL
- & , QAOLI_CURR=scalar(ims,kms,jms,P_QAOLI), F_QAOLI=F_QAOLI & ! for Jensen ISHMAEL
- & , QI2_CURR=moist(ims,kms,jms,P_QI2), F_QI2=F_QI2 & ! for P3
- & , QNI2_CURR=scalar(ims,kms,jms,P_QNI2), F_QNI2=F_QNI2 & ! for P3
- & , QIR2_CURR=scalar(ims,kms,jms,P_QIR2), F_QIR2=F_QIR2 & ! for P3
- & , QIB2_CURR=scalar(ims,kms,jms,P_QIB2), F_QIB2=F_QIB2 & ! for P3
- & , QVOLI2_CURR=scalar(ims,kms,jms,P_QVOLI2), F_QVOLI2=F_QVOLI2 & ! for Jensen ISHMAEL
- & , QAOLI2_CURR=scalar(ims,kms,jms,P_QAOLI2), F_QAOLI2=F_QAOLI2 & ! for Jensen ISHMAEL
- & , QI3_CURR=moist(ims,kms,jms,P_QI3), F_QI3=F_QI3 & ! for Jensen ISHMAEL
- & , QNI3_CURR=scalar(ims,kms,jms,P_QNI3), F_QNI3=F_QNI3 & ! for Jensen ISHMAEL
- & , QVOLI3_CURR=scalar(ims,kms,jms,P_QVOLI3), F_QVOLI3=F_QVOLI3 & ! for Jensen ISHMAEL
- & , QAOLI3_CURR=scalar(ims,kms,jms,P_QAOLI3), F_QAOLI3=F_QAOLI3 & ! for Jensen ISHMAEL
-! & , QZR_CURR=scalar(ims,kms,jms,P_QZR), F_QZR=F_QZR & ! for milbrandt3mom
-! & , QZI_CURR=scalar(ims,kms,jms,P_QZI), F_QZI=F_QZI & ! "
-! & , QZS_CURR=scalar(ims,kms,jms,P_QZS), F_QZS=F_QZS & ! "
-! & , QZG_CURR=scalar(ims,kms,jms,P_QZG), F_QZG=F_QZG & ! "
-! & , QZH_CURR=scalar(ims,kms,jms,P_QZH), F_QZH=F_QZH & ! "
- & , QVOLG_CURR=scalar(ims,kms,jms,P_QVOLG), F_QVOLG=F_QVOLG & ! for nssl_2mom
- & , QVOLH_CURR=scalar(ims,kms,jms,P_QVOLH), F_QVOLH=F_QVOLH & ! for nssl_2mom
- & , QDCN_CURR=scalar(ims,kms,jms,P_QDCN), F_QDCN=F_QDCN & ! for ntu3m
- & , QTCN_CURR=scalar(ims,kms,jms,P_QTCN), F_QTCN=F_QTCN & ! for ntu3m
- & , QCCN_CURR=scalar(ims,kms,jms,P_QCCN), F_QCCN=F_QCCN & ! for ntu3m
- & , QRCN_CURR=scalar(ims,kms,jms,P_QRCN), F_QRCN=F_QRCN & ! for ntu3m
- & , QNIN_CURR=scalar(ims,kms,jms,P_QNIN), F_QNIN=F_QNIN & ! for ntu3m
- & , FI_CURR=scalar(ims,kms,jms,P_FI), F_FI=F_FI & ! for ntu3m
- & , FS_CURR=scalar(ims,kms,jms,P_FS), F_FS=F_FS & ! for ntu3m
- & , VI_CURR=scalar(ims,kms,jms,P_VI), F_VI=F_VI & ! for ntu3m
- & , VS_CURR=scalar(ims,kms,jms,P_VS), F_VS=F_VS & ! for ntu3m
- & , VG_CURR=scalar(ims,kms,jms,P_VG), F_VG=F_VG & ! for ntu3m
- & , AI_CURR=scalar(ims,kms,jms,P_AI), F_AI=F_AI & ! for ntu3m
- & , AS_CURR=scalar(ims,kms,jms,P_AS), F_AS=F_AS & ! for ntu3m
- & , AG_CURR=scalar(ims,kms,jms,P_AG), F_AG=F_AG & ! for ntu3m
- & , AH_CURR=scalar(ims,kms,jms,P_AH), F_AH=F_AH & ! for ntu3m
- & , I3M_CURR=scalar(ims,kms,jms,P_I3M), F_I3M=F_I3m & ! for ntu3m
- & , cu_used=config_flags%cu_used &
- & , qrcuten=grid%rqrcuten, qscuten=grid%rqscuten &
- & , qicuten=grid%rqicuten, qccuten=grid%rqccuten &
- & , HAIL=config_flags%gsfcgce_hail & ! for gsfcgce
- & , ICE2=config_flags%gsfcgce_2ice & ! for gsfcgce
- & , PHYS_TOT=grid%phys_tot & ! for gsfcgce
- & , PHYSC=grid%physc & ! for gsfcgce
- & , PHYSE=grid%physe & ! for gsfcgce
- & , PHYSD=grid%physd & ! for gsfcgce
- & , PHYSS=grid%physs & ! for gsfcgce
- & , PHYSM=grid%physm & ! for gsfcgce
- & , PHYSF=grid%physf & ! for gsfcgce
-
- & , ACPHYS_TOT=grid%acphys_tot & ! for gsfcgce
- & , ACPHYSC=grid%acphysc & ! for gsfcgce
- & , ACPHYSE=grid%acphyse & ! for gsfcgce
- & , ACPHYSD=grid%acphysd & ! for gsfcgce
- & , ACPHYSS=grid%acphyss & ! for gsfcgce
- & , ACPHYSM=grid%acphysm & ! for gsfcgce
- & , ACPHYSF=grid%acphysf & ! for gsfcgce
-
- & , RE_CLOUD_GSFC=grid%re_cloud_gsfc & ! for gsfcgce
- & , RE_RAIN_GSFC=grid%re_rain_gsfc & ! for gsfcgce
- & , RE_ICE_GSFC=grid%re_ice_gsfc & ! for gsfcgce
- & , RE_SNOW_GSFC=grid%re_snow_gsfc & ! for gsfcgce
- & , RE_GRAUPEL_GSFC=grid%re_graupel_gsfc & ! for gsfcgce
- & , RE_HAIL_GSFC=grid%re_hail_gsfc & ! for gsfcgce
- & , PRECR3D=grid%precr3d, PRECI3D=grid%preci3d, PRECS3D=grid%precs3d &
- & , PRECG3D=grid%precg3d, PRECH3D=grid%prech3d &
-#if ( WRF_CHEM == 1)
- & , GSFCGCE_GOCART_COUPLING=config_flags%gsfcgce_gocart_coupling &
- & , ICN_DIAG=grid%icn_diag & ! inline gocart
- & , NC_DIAG=grid%nc_diag & ! inline gocart
-#endif
-!NUWRF JJS 20110525 ^^^^^
-! & , ccntype=config_flags%milbrandt_ccntype & ! for milbrandt (2mom)
-! YLIN
-! RI_CURR INPUT
- & , RI_CURR=grid%rimi &
- & , re_cloud=grid%re_cloud, re_ice=grid%re_ice, re_snow=grid%re_snow & ! G. Thompson
- & , has_reqc=grid%has_reqc, has_reqi=grid%has_reqi, has_reqs=grid%has_reqs & ! G. Thompson
- & , qnwfa2d=grid%qnwfa2d, qnifa2d=grid%qnifa2d & ! G. Thompson
- & , diagflag=diag_flag, do_radar_ref=config_flags%do_radar_ref &
- & , ke_diag=ke_diag &
- & ,u=grid%u_phy,v=grid%v_phy &
- & ,scalar=scalar,num_scalar=num_scalar &
- & ,TH_OLD=grid%th_old &
- & ,QV_OLD=grid%qv_old &
- & ,xlat=grid%xlat,xlong=grid%xlong,IVGTYP=grid%ivgtyp &
- & , EFFR_CURR=scalar(ims,kms,jms,P_EFFR), F_EFFR=F_EFFR & ! for SBM
- & , ICE_EFFR_CURR=scalar(ims,kms,jms,P_ICE_EFFR), F_ICE_EFFR=F_ICE_EFFR & ! for SBM
- & , TOT_EFFR_CURR=scalar(ims,kms,jms,P_TOT_EFFR), F_TOT_EFFR=F_TOT_EFFR & ! for SBM
- & , QIC_EFFR_CURR=scalar(ims,kms,jms,P_QIC_EFFR), F_QIC_EFFR=F_QIC_EFFR & ! for SBM
- & , QIP_EFFR_CURR=scalar(ims,kms,jms,P_QIP_EFFR), F_QIP_EFFR=F_QIP_EFFR & ! for SBM
- & , QID_EFFR_CURR=scalar(ims,kms,jms,P_QID_EFFR), F_QID_EFFR=F_QID_EFFR & ! for SBM
- & ,kext_ql=grid%kext_ql &
- & ,kext_qs=grid%kext_qs &
- & ,kext_qg=grid%kext_qg &
- & ,kext_qh=grid%kext_qh &
- & ,kext_qa=grid%kext_qa &
- & ,kext_qic=grid%kext_qic &
- & ,kext_qip=grid%kext_qip &
- & ,kext_qid=grid%kext_qid &
- & ,kext_ft_qic=grid%kext_ft_qic &
- & ,kext_ft_qip=grid%kext_ft_qip &
- & ,kext_ft_qid=grid%kext_ft_qid &
- & ,kext_ft_qs=grid%kext_ft_qs &
- & ,kext_ft_qg=grid%kext_ft_qg &
- & ,height=grid%height &
- & ,tempc=grid%tempc &
- & ,ccn_conc=grid%ccn_conc & ! RAS
- & ,sbmradar=sbmradar,num_sbmradar=num_sbmradar & ! for SBM
- & ,sbm_diagnostics=config_flags%sbm_diagnostics & ! for SBM
- & ,aerocu=aerocu &
- & ,aercu_fct=config_flags%aercu_fct &
- & ,aercu_opt=config_flags%aercu_opt &
- & ,no_src_types_cu=grid%no_src_types_cu &
- & ,PBL=grid%bl_pbl_physics,EFCG=grid%EFCG,EFIG=grid%EFIG,EFSG=grid%EFSG &
- & ,WACT=grid%WACT,CCN1_GS=grid%CCN1_GS,CCN2_GS=grid%CCN2_GS,CCN3_GS=grid%CCN3_GS &
- & ,CCN4_GS=grid%CCN4_GS,CCN5_GS=grid%CCN5_GS,CCN6_GS=grid%CCN6_GS &
- & ,CCN7_GS=grid%CCN7_GS,NR_CU=grid%NR_CU,QR_CU=grid%QR_CU,NS_CU=grid%NS_CU &
- & ,QS_CU=grid%QS_CU,CU_UAF=grid%CU_UAF,mskf_refl_10cm=grid%mskf_refl_10cm)
-
-BENCH_END(micro_driver_tim)
-
-#if 0
-BENCH_START(microswap_2)
-! for load balancing; communication to redistribute the points
- IF ( config_flags%mp_physics .EQ. ETAMPNEW .OR. &
- & config_flags%mp_physics .EQ. FER_MP_HIRES) THEN
-#include "SWAP_ETAMP_NEW.inc"
- ELSE IF ( config_flags%mp_physics .EQ. WSM3SCHEME ) THEN
-#include "SWAP_WSM3.inc"
- ENDIF
-BENCH_END(microswap_2)
-#endif
-
- CALL wrf_debug ( 200 , ' call moist_physics_finish' )
-BENCH_START(moist_phys_end_tim)
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij, its, ite, jts, jte, im, ii, jj, kk )
-
- DO ij = 1 , grid%num_tiles
-
- its = max(grid%i_start(ij),ids)
- ite = min(grid%i_end(ij),ide-1)
- jts = max(grid%j_start(ij),jds)
- jte = min(grid%j_end(ij),jde-1)
-
- CALL microphysics_zero_outb ( &
- moist , num_moist , config_flags , &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, &
- k_start , k_end )
-
- CALL microphysics_zero_outb ( &
- scalar , num_scalar , config_flags , &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, &
- k_start , k_end )
-
- CALL microphysics_zero_outb ( &
- chem , num_chem , config_flags , &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, &
- k_start , k_end )
- CALL microphysics_zero_outb ( &
- tracer , num_tracer , config_flags , &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, &
- k_start , k_end )
-
- IF ( config_flags%periodic_x ) THEN
- its = max(grid%i_start(ij),ids)
- ite = min(grid%i_end(ij),ide-1)
- ELSE
- its = max(grid%i_start(ij),ids+sz)
- ite = min(grid%i_end(ij),ide-1-sz)
- ENDIF
- jts = max(grid%j_start(ij),jds+sz)
- jte = min(grid%j_end(ij),jde-1-sz)
-
- CALL microphysics_zero_outa ( &
- moist , num_moist , config_flags , &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, &
- k_start , k_end )
-
- CALL microphysics_zero_outa ( &
- scalar , num_scalar , config_flags , &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, &
- k_start , k_end )
-
- CALL microphysics_zero_outa ( &
- chem , num_chem , config_flags , &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, &
- k_start , k_end )
-
- CALL microphysics_zero_outa ( &
- tracer , num_tracer , config_flags , &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, &
- k_start , k_end )
-
- CALL moist_physics_finish_em( grid%t_2, grid%t_1, t0, grid%muts, th_phy, &
- grid%h_diabatic, dtm, &
- moist(ims,kms,jms,P_QV),grid%qv_diabatic, &
- moist(ims,kms,jms,P_QC),grid%qc_diabatic, &
- grid%th_phy_m_t0, &
- config_flags, &
-#if ( WRF_DFI_RADAR == 1 )
- grid%dfi_tten_rad,grid%dfi_stage, &
-#endif
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, &
- k_start , k_end )
-
- END DO
- !$OMP END PARALLEL DO
-
-#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
-# include "HALO_EM_THETAM.inc"
-# include "PERIOD_EM_THETAM.inc"
-#endif
- its=ips ; ite = ipe
- jts=jps ; jte = jpe
- CALL set_physical_bc3d( grid%h_diabatic, 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- its, ite, jts, jte, &
- k_start , k_end )
- ENDIF ! microphysics test
-
-!-----------------------------------------------------------
-! filter for moist variables post-microphysics and end of timestep
-!-----------------------------------------------------------
-
- IF (config_flags%polar) THEN
- IF ( num_3d_m >= PARAM_FIRST_SCALAR ) THEN
- CALL wrf_debug ( 200 , ' call filter moist' )
- DO im = PARAM_FIRST_SCALAR, num_3d_m
- IF ( config_flags%coupled_filtering ) THEN
- CALL couple_scalars_for_filter ( FIELD=moist(ims,kms,jms,im) &
- ,MU=grid%mu_2 , MUB=grid%mub &
- ,C1=grid%c1h , C2=grid%c2h &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe )
- END IF
-
- CALL pxft ( grid=grid &
- ,lineno=__LINE__ &
- ,flag_uv = 0 &
- ,flag_rurv = 0 &
- ,flag_wph = 0 &
- ,flag_ww = 0 &
- ,flag_t = 0 &
- ,flag_mu = 0 &
- ,flag_mut = 0 &
- ,flag_moist = im &
- ,flag_chem = 0 &
- ,flag_tracer = 0 &
- ,flag_scalar = 0 &
- ,actual_distance_average=config_flags%actual_distance_average&
- ,pos_def = config_flags%pos_def &
- ,swap_pole_with_next_j = config_flags%swap_pole_with_next_j &
- ,moist=moist,chem=chem,tracer=tracer,scalar=scalar &
- ,fft_filter_lat = config_flags%fft_filter_lat &
- ,dclat = dclat &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe &
- ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
- ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
-
- IF ( config_flags%coupled_filtering ) THEN
- CALL uncouple_scalars_for_filter ( FIELD=moist(ims,kms,jms,im) &
- ,MU=grid%mu_2 , MUB=grid%mub &
- ,C1=grid%c1h , C2=grid%c2h &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe )
- END IF
- ENDDO
- ENDIF
- ENDIF
-
-!-----------------------------------------------------------
-! end filter for moist variables post-microphysics and end of timestep
-!-----------------------------------------------------------
-
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij, its, ite, jts, jte, im, ii, jj, kk )
- scalar_tile_loop_1ba: DO ij = 1 , grid%num_tiles
-
- IF ( config_flags%periodic_x ) THEN
- its = max(grid%i_start(ij),ids)
- ite = min(grid%i_end(ij),ide-1)
- ELSE
- its = max(grid%i_start(ij),ids+sz)
- ite = min(grid%i_end(ij),ide-1-sz)
- ENDIF
- jts = max(grid%j_start(ij),jds+sz)
- jte = min(grid%j_end(ij),jde-1-sz)
-
- CALL calc_p_rho_phi( moist, num_3d_m, config_flags%hypsometric_opt, &
- grid%al, grid%alb, grid%mu_2, grid%muts, &
- grid%c1h, grid%c2h, grid%c3h, grid%c4h, grid%c3f, grid%c4f, &
- grid%ph_2, grid%phb, grid%p, grid%pb, grid%t_2, &
- p0, t0, grid%p_top, grid%znu, grid%znw, grid%dnw, grid%rdnw, &
- grid%rdn, config_flags%non_hydrostatic,config_flags%use_theta_m, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, &
- k_start , k_end )
-
- END DO scalar_tile_loop_1ba
- !$OMP END PARALLEL DO
-BENCH_END(moist_phys_end_tim)
-
- IF (.not. config_flags%non_hydrostatic) THEN
-#ifdef DM_PARALLEL
-# include "HALO_EM_HYDRO_UV.inc"
-# include "PERIOD_EM_HYDRO_UV.inc"
-#endif
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
- CALL diagnose_w( ph_tend, grid%ph_2, grid%ph_1, grid%w_2, grid%muts, &
- grid%c1f, grid%c2f, dt_rk, &
- grid%u_2, grid%v_2, grid%ht, &
- grid%cf1, grid%cf2, grid%cf3, grid%rdx, grid%rdy, grid%msftx, grid%msfty, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- END DO
- !$OMP END PARALLEL DO
-
- END IF
-
- CALL wrf_debug ( 200 , ' call chem polar filter ' )
-
-!-----------------------------------------------------------
-! filter for chem and scalar variables at end of timestep
-!-----------------------------------------------------------
-
- IF (config_flags%polar) THEN
-
- IF ( num_3d_c >= PARAM_FIRST_SCALAR ) then
- chem_filter_loop: DO im = PARAM_FIRST_SCALAR, num_3d_c
- IF ( config_flags%coupled_filtering ) THEN
- CALL couple_scalars_for_filter ( FIELD=chem(ims,kms,jms,im) &
- ,MU=grid%mu_2 , MUB=grid%mub &
- ,C1=grid%c1h , C2=grid%c2h &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe )
- END IF
-
- CALL pxft ( grid=grid &
- ,lineno=__LINE__ &
- ,flag_uv = 0 &
- ,flag_rurv = 0 &
- ,flag_wph = 0 &
- ,flag_ww = 0 &
- ,flag_t = 0 &
- ,flag_mu = 0 &
- ,flag_mut = 0 &
- ,flag_moist = 0 &
- ,flag_chem = im &
- ,flag_tracer = 0 &
- ,flag_scalar = 0 &
- ,actual_distance_average=config_flags%actual_distance_average&
- ,pos_def = config_flags%pos_def &
- ,swap_pole_with_next_j = config_flags%swap_pole_with_next_j &
- ,moist=moist,chem=chem,tracer=tracer,scalar=scalar &
- ,fft_filter_lat = config_flags%fft_filter_lat &
- ,dclat = dclat &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe &
- ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
- ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
-
- IF ( config_flags%coupled_filtering ) THEN
- CALL uncouple_scalars_for_filter ( FIELD=chem(ims,kms,jms,im) &
- ,MU=grid%mu_2 , MUB=grid%mub &
- ,C1=grid%c1h , C2=grid%c2h &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe )
- END IF
- ENDDO chem_filter_loop
- ENDIF
- IF ( num_tracer >= PARAM_FIRST_SCALAR ) then
- tracer_filter_loop: DO im = PARAM_FIRST_SCALAR, num_tracer
- IF ( config_flags%coupled_filtering ) THEN
- CALL couple_scalars_for_filter ( FIELD=tracer(ims,kms,jms,im) &
- ,MU=grid%mu_2 , MUB=grid%mub &
- ,C1=grid%c1h , C2=grid%c2h &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe )
- END IF
-
- CALL pxft ( grid=grid &
- ,lineno=__LINE__ &
- ,flag_uv = 0 &
- ,flag_rurv = 0 &
- ,flag_wph = 0 &
- ,flag_ww = 0 &
- ,flag_t = 0 &
- ,flag_mu = 0 &
- ,flag_mut = 0 &
- ,flag_moist = 0 &
- ,flag_chem = 0 &
- ,flag_tracer = im &
- ,flag_scalar = 0 &
- ,actual_distance_average=config_flags%actual_distance_average&
- ,pos_def = config_flags%pos_def &
- ,swap_pole_with_next_j = config_flags%swap_pole_with_next_j &
- ,moist=moist,chem=chem,tracer=tracer,scalar=scalar &
- ,fft_filter_lat = config_flags%fft_filter_lat &
- ,dclat = dclat &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe &
- ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
- ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
-
- IF ( config_flags%coupled_filtering ) THEN
- CALL uncouple_scalars_for_filter ( FIELD=tracer(ims,kms,jms,im) &
- ,MU=grid%mu_2 , MUB=grid%mub &
- ,C1=grid%c1h , C2=grid%c2h &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe )
- END IF
- ENDDO tracer_filter_loop
- ENDIF
-
- IF ( num_3d_s >= PARAM_FIRST_SCALAR ) then
- scalar_filter_loop: DO im = PARAM_FIRST_SCALAR, num_3d_s
- IF ( config_flags%coupled_filtering ) THEN
- CALL couple_scalars_for_filter ( FIELD=scalar(ims,kms,jms,im) &
- ,MU=grid%mu_2 , MUB=grid%mub &
- ,C1=grid%c1h , C2=grid%c2h &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe )
- END IF
-
- CALL pxft ( grid=grid &
- ,lineno=__LINE__ &
- ,flag_uv = 0 &
- ,flag_rurv = 0 &
- ,flag_wph = 0 &
- ,flag_ww = 0 &
- ,flag_t = 0 &
- ,flag_mu = 0 &
- ,flag_mut = 0 &
- ,flag_moist = 0 &
- ,flag_chem = 0 &
- ,flag_tracer = 0 &
- ,flag_scalar = im &
- ,actual_distance_average=config_flags%actual_distance_average&
- ,pos_def = config_flags%pos_def &
- ,swap_pole_with_next_j = config_flags%swap_pole_with_next_j &
- ,moist=moist,chem=chem,tracer=tracer,scalar=scalar &
- ,fft_filter_lat = config_flags%fft_filter_lat &
- ,dclat = dclat &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe &
- ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
- ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
-
- IF ( config_flags%coupled_filtering ) THEN
- CALL uncouple_scalars_for_filter ( FIELD=scalar(ims,kms,jms,im) &
- ,MU=grid%mu_2 , MUB=grid%mub &
- ,C1=grid%c1h , C2=grid%c2h &
- ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
- ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
- ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe )
- END IF
- ENDDO scalar_filter_loop
- ENDIF
- ENDIF
-
-!-----------------------------------------------------------
-! end filter for chem and scalar variables at end of timestep
-!-----------------------------------------------------------
-
- ! We're finished except for boundary condition (and patch) update
-
- ! Boundary condition time (or communication time). At this time, we have
- ! implemented periodic and symmetric physical boundary conditions.
-
- ! b.c. routine for data within patch.
-
- ! we need to do both time levels of
- ! data because the time filter only works in the physical solution space.
-
- ! First, do patch communications for boundary conditions (periodicity)
-
-!-----------------------------------------------------------
-! Stencils for patch communications (WCS, 29 June 2001)
-!
-! here's where we need a wide comm stencil - these are the
-! uncoupled variables so are used for high order calc in
-! advection and mixong routines.
-!
-! * * * * *
-! * * * * * * * * *
-! * + * * + * * * + * *
-! * * * * * * * * *
-! * * * * *
-!
-! grid%u_1 x
-! grid%u_2 x
-! grid%v_1 x
-! grid%v_2 x
-! grid%w_1 x
-! grid%w_2 x
-! grid%t_1 x
-! grid%t_2 x
-! grid%ph_1 x
-! grid%ph_2 x
-! grid%tke_1 x
-! grid%tke_2 x
-!
-! 2D variables
-! grid%mu_1 x
-! grid%mu_2 x
-!
-! 4D variables
-! moist x
-! chem x
-! scalar x
-!----------------------------------------------------------
-
-
-#ifdef DM_PARALLEL
- IF ( config_flags%h_mom_adv_order <= 4 .and. config_flags%h_sca_adv_order <= 4 ) THEN
-# include "HALO_EM_D3_3.inc"
- ELSE IF ( config_flags%h_mom_adv_order <= 6 .and. config_flags%h_sca_adv_order <= 6 ) THEN
-# include "HALO_EM_D3_5.inc"
- ELSE
- WRITE(wrf_err_message,*)'solve_em: invalid h_mom_adv_order or h_sca_adv_order = ', &
- config_flags%h_mom_adv_order, config_flags%h_sca_adv_order
- CALL wrf_error_fatal(TRIM(wrf_err_message))
- ENDIF
-# include "PERIOD_BDY_EM_D3.inc"
-# include "PERIOD_BDY_EM_MOIST.inc"
-# include "PERIOD_BDY_EM_CHEM.inc"
-# include "PERIOD_BDY_EM_TRACER.inc"
-# include "PERIOD_BDY_EM_SCALAR.inc"
-#endif
-
-! now set physical b.c on a patch
-
-BENCH_START(bc_2d_tim)
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- tile_bc_loop_2: DO ij = 1 , grid%num_tiles
-
- CALL wrf_debug ( 200 , ' call set_phys_bc_dry_2' )
-
- CALL set_phys_bc_dry_2( config_flags, &
- grid%u_1, grid%u_2, grid%v_1, grid%v_2, grid%w_1, grid%w_2, &
- grid%t_1, grid%t_2, grid%ph_1, grid%ph_2, grid%mu_1, grid%mu_2, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- CALL set_physical_bc3d( grid%tke_1, 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end-1 )
-
- CALL set_physical_bc3d( grid%tke_2 , 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- moisture_loop_bdy_2 : DO im = PARAM_FIRST_SCALAR , num_3d_m
-
- CALL set_physical_bc3d( moist(ims,kms,jms,im), 'p', &
- config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- END DO moisture_loop_bdy_2
-
- chem_species_bdy_loop_2 : DO ic = PARAM_FIRST_SCALAR , num_3d_c
-
- CALL set_physical_bc3d( chem(ims,kms,jms,ic) , 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- END DO chem_species_bdy_loop_2
-
- tracer_species_bdy_loop_2 : DO ic = PARAM_FIRST_SCALAR , num_tracer
-
- CALL set_physical_bc3d( tracer(ims,kms,jms,ic) , 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- END DO tracer_species_bdy_loop_2
-
- scalar_species_bdy_loop_2 : DO is = PARAM_FIRST_SCALAR , num_3d_s
-
- CALL set_physical_bc3d( scalar(ims,kms,jms,is) , 'p', config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- END DO scalar_species_bdy_loop_2
-
- END DO tile_bc_loop_2
- !$OMP END PARALLEL DO
-BENCH_END(bc_2d_tim)
-
-! this code forces boundary values to specified values to avoid drift
-
- IF( config_flags%specified .or. config_flags%nested ) THEN
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- tile_bc_loop_3: DO ij = 1 , grid%num_tiles
-
- CALL wrf_debug ( 200 , ' call spec_bdy_final' )
-
- CALL spec_bdy_final ( grid%u_2, grid%muus, grid%c1h, grid%c2h, grid%msfuy, &
- grid%u_bxs, grid%u_bxe, grid%u_bys, grid%u_bye, &
- grid%u_btxs,grid%u_btxe,grid%u_btys,grid%u_btye, &
- 'u', config_flags, &
- config_flags%spec_bdy_width, grid%spec_zone, &
- grid%dtbc, &
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- ips,ipe, jps,jpe, kps,kpe, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- CALL spec_bdy_final ( grid%v_2, grid%muvs, grid%c1h, grid%c2h, grid%msfvx, &
- grid%v_bxs, grid%v_bxe, grid%v_bys, grid%v_bye, &
- grid%v_btxs,grid%v_btxe,grid%v_btys,grid%v_btye, &
- 'v', config_flags, &
- config_flags%spec_bdy_width, grid%spec_zone, &
- grid%dtbc, &
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- ips,ipe, jps,jpe, kps,kpe, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- IF( config_flags%nested) THEN
- CALL spec_bdy_final ( grid%w_2, grid%muts, grid%c1f, grid%c2f, grid%msfty, &
- grid%w_bxs, grid%w_bxe, grid%w_bys, grid%w_bye, &
- grid%w_btxs,grid%w_btxe,grid%w_btys,grid%w_btye, &
- 'w', config_flags, &
- config_flags%spec_bdy_width, grid%spec_zone, &
- grid%dtbc, &
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- ips,ipe, jps,jpe, kps,kpe, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- ENDIF
-
- CALL spec_bdy_final ( grid%t_2, grid%muts, grid%c1h, grid%c2h, grid%msfty,&
- grid%t_bxs, grid%t_bxe, grid%t_bys, grid%t_bye, &
- grid%t_btxs,grid%t_btxe,grid%t_btys,grid%t_btye, &
- 't', config_flags, &
- config_flags%spec_bdy_width, grid%spec_zone, &
- grid%dtbc, &
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- ips,ipe, jps,jpe, kps,kpe, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- CALL spec_bdy_final ( grid%ph_2, grid%muts, grid%c1f, grid%c2f, grid%msfty, &
- grid%ph_bxs, grid%ph_bxe, grid%ph_bys, grid%ph_bye, &
- grid%ph_btxs,grid%ph_btxe,grid%ph_btys,grid%ph_btye, &
- 'h', config_flags, &
- config_flags%spec_bdy_width, grid%spec_zone, &
- grid%dtbc, &
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- ips,ipe, jps,jpe, kps,kpe, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
-
- CALL spec_bdy_final ( grid%mu_2, grid%muts, grid%c1h, grid%c2h, grid%msfty, &
- grid%mu_bxs, grid%mu_bxe, grid%mu_bys, grid%mu_bye, &
- grid%mu_btxs,grid%mu_btxe,grid%mu_btys,grid%mu_btye, &
- 'm', config_flags, &
- config_flags%spec_bdy_width, grid%spec_zone, &
- grid%dtbc, &
- ids,ide, jds,jde, 1, 1, & ! domain dims
- ims,ime, jms,jme, 1, 1, & ! memory dims
- ips,ipe, jps,jpe, 1, 1, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- 1 , 1 )
-
- moisture_loop_bdy_3 : DO im = PARAM_FIRST_SCALAR , num_3d_m
-
- IF ( im .EQ. P_QV .OR. config_flags%nested .OR. &
- ( config_flags%specified .AND. config_flags%have_bcs_moist ) ) THEN
- CALL spec_bdy_final ( moist(ims,kms,jms,im), grid%muts, &
- grid%c1h, grid%c2h, grid%msfty, &
- moist_bxs(jms,kms,1,im),moist_bxe(jms,kms,1,im), &
- moist_bys(ims,kms,1,im),moist_bye(ims,kms,1,im), &
- moist_btxs(jms,kms,1,im),moist_btxe(jms,kms,1,im), &
- moist_btys(ims,kms,1,im),moist_btye(ims,kms,1,im), &
- 't', config_flags, &
- config_flags%spec_bdy_width, grid%spec_zone, &
- grid%dtbc, &
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- ips,ipe, jps,jpe, kps,kpe, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- ENDIF
-
- END DO moisture_loop_bdy_3
-
-#if (WRF_CHEM == 1)
- IF (num_3d_c >= PARAM_FIRST_SCALAR) THEN
- chem_species_bdy_loop_3 : DO ic = PARAM_FIRST_SCALAR , num_3d_c
-
- IF( ( config_flags%nested ) ) THEN
- CALL spec_bdy_final ( chem(ims,kms,jms,ic), grid%muts, &
- grid%c1h, grid%c2h, grid%msfty, &
- chem_bxs(jms,kms,1,ic),chem_bxe(jms,kms,1,ic), &
- chem_bys(ims,kms,1,ic),chem_bye(ims,kms,1,ic), &
- chem_btxs(jms,kms,1,ic),chem_btxe(jms,kms,1,ic), &
- chem_btys(ims,kms,1,ic),chem_btye(ims,kms,1,ic), &
- 't', config_flags, &
- config_flags%spec_bdy_width, grid%spec_zone, &
- grid%dtbc, &
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- ips,ipe, jps,jpe, kps,kpe, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- ENDIF
-
- END DO chem_species_bdy_loop_3
- ENDIF
-#endif
-
- tracer_species_bdy_loop_3 : DO im = PARAM_FIRST_SCALAR , num_tracer
-
- IF( ( config_flags%nested ) ) THEN
- CALL spec_bdy_final ( tracer(ims,kms,jms,im), grid%muts, &
- grid%c1h, grid%c2h, grid%msfty, &
- tracer_bxs(jms,kms,1,im),tracer_bxe(jms,kms,1,im), &
- tracer_bys(ims,kms,1,im),tracer_bye(ims,kms,1,im), &
- tracer_btxs(jms,kms,1,im),tracer_btxe(jms,kms,1,im), &
- tracer_btys(ims,kms,1,im),tracer_btye(ims,kms,1,im), &
- 't', config_flags, &
- config_flags%spec_bdy_width, grid%spec_zone, &
- grid%dtbc, &
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- ips,ipe, jps,jpe, kps,kpe, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- ENDIF
-
- END DO tracer_species_bdy_loop_3
-
- scalar_species_bdy_loop_3 : DO is = PARAM_FIRST_SCALAR , num_3d_s
-
- IF( ( config_flags%nested ) ) THEN
- CALL spec_bdy_final ( scalar(ims,kms,jms,is), grid%muts, &
- grid%c1h, grid%c2h, grid%msfty, &
- scalar_bxs(jms,kms,1,is),scalar_bxe(jms,kms,1,is), &
- scalar_bys(ims,kms,1,is),scalar_bye(ims,kms,1,is), &
- scalar_btxs(jms,kms,1,is),scalar_btxe(jms,kms,1,is), &
- scalar_btys(ims,kms,1,is),scalar_btye(ims,kms,1,is), &
- 't', config_flags, &
- config_flags%spec_bdy_width, grid%spec_zone, &
- grid%dtbc, &
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- ips,ipe, jps,jpe, kps,kpe, & ! patch dims
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start , k_end )
- ENDIF
-
- END DO scalar_species_bdy_loop_3
-
- END DO tile_bc_loop_3
- !$OMP END PARALLEL DO
-
- ENDIF
-
-! reset surface w for consistency
-
-#ifdef DM_PARALLEL
-# include "HALO_EM_C.inc"
-# include "PERIOD_BDY_EM_E.inc"
-#endif
-
- CALL wrf_debug ( 10 , ' call set_w_surface' )
- fill_w_flag = .false.
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
- DO ij = 1 , grid%num_tiles
- CALL set_w_surface( config_flags, grid%znw, fill_w_flag, &
- grid%w_2, grid%ht, grid%u_2, grid%v_2, &
- grid%cf1, grid%cf2, grid%cf3, grid%rdx, grid%rdy,&
- grid%msftx, grid%msfty, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- grid%i_start(ij), grid%i_end(ij), &
- grid%j_start(ij), grid%j_end(ij), &
- k_start, k_end )
-! its, ite, jts, jte, k_start, min(k_end,kde-1), &
-
- END DO
- !$OMP END PARALLEL DO
-
-!-----------------------------------------------------------
-! After all of the RK steps, after the microphysics, after p-rho-phi,
-! after w, after filtering, we have data ready to use.
-!-----------------------------------------------------------
-
- CALL after_all_rk_steps ( grid, config_flags, &
- moist, chem, tracer, scalar, &
- th_phy, pi_phy, p_phy, &
- p8w, t8w, dz8w, &
- REAL(curr_secs,8), curr_secs2, &
- diag_flag, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- imsx, imex, jmsx, jmex, kmsx, kmex, &
- ipsx, ipex, jpsx, jpex, kpsx, kpex, &
- imsy, imey, jmsy, jmey, kmsy, kmey, &
- ipsy, ipey, jpsy, jpey, kpsy, kpey )
-
-
-
-#ifdef DM_PARALLEL
-!-----------------------------------------------------------------------
-! see above
-!--------------------------------------------------------------
- CALL wrf_debug ( 200 , ' call HALO_RK_E' )
- IF ( config_flags%h_mom_adv_order <= 4 .and. config_flags%h_sca_adv_order <= 4 ) THEN
-# include "HALO_EM_E_3.inc"
- ELSE IF ( config_flags%h_mom_adv_order <= 6 .and. config_flags%h_sca_adv_order <= 6 ) THEN
-# include "HALO_EM_E_5.inc"
- ELSE
- WRITE(wrf_err_message,*)'solve_em: invalid h_mom_adv_order or h_sca_adv_order = ', &
- config_flags%h_mom_adv_order, config_flags%h_sca_adv_order
- CALL wrf_error_fatal(TRIM(wrf_err_message))
- ENDIF
-#endif
-
-#ifdef DM_PARALLEL
- IF ( num_moist >= PARAM_FIRST_SCALAR ) THEN
-!-----------------------------------------------------------------------
-! see above
-!--------------------------------------------------------------
- CALL wrf_debug ( 200 , ' call HALO_RK_MOIST' )
- IF ( config_flags%h_sca_adv_order <= 4 ) THEN
-# include "HALO_EM_MOIST_E_3.inc"
- ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
-# include "HALO_EM_MOIST_E_5.inc"
- ELSE
- WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
- CALL wrf_error_fatal(TRIM(wrf_err_message))
- ENDIF
- ENDIF
- IF ( num_chem >= PARAM_FIRST_SCALAR ) THEN
-!-----------------------------------------------------------------------
-! see above
-!--------------------------------------------------------------
- CALL wrf_debug ( 200 , ' call HALO_RK_CHEM' )
- IF ( config_flags%h_sca_adv_order <= 4 ) THEN
-# include "HALO_EM_CHEM_E_3.inc"
- ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
-# include "HALO_EM_CHEM_E_5.inc"
- ELSE
- WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
- CALL wrf_error_fatal(TRIM(wrf_err_message))
- ENDIF
- ENDIF
- IF ( num_tracer >= PARAM_FIRST_SCALAR ) THEN
-!-----------------------------------------------------------------------
-! see above
-!--------------------------------------------------------------
- CALL wrf_debug ( 200 , ' call HALO_RK_TRACER' )
- IF ( config_flags%h_sca_adv_order <= 4 ) THEN
-# include "HALO_EM_TRACER_E_3.inc"
- ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
-# include "HALO_EM_TRACER_E_5.inc"
- ELSE
- WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
- CALL wrf_error_fatal(TRIM(wrf_err_message))
- ENDIF
- ENDIF
- IF ( num_scalar >= PARAM_FIRST_SCALAR ) THEN
-!-----------------------------------------------------------------------
-! see above
-!--------------------------------------------------------------
- CALL wrf_debug ( 200 , ' call HALO_RK_SCALAR' )
- IF ( config_flags%h_sca_adv_order <= 4 ) THEN
-# include "HALO_EM_SCALAR_E_3.inc"
- ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
-# include "HALO_EM_SCALAR_E_5.inc"
- ELSE
- WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
- CALL wrf_error_fatal(TRIM(wrf_err_message))
- ENDIF
- ENDIF
-#endif
-
-! Max values of CFL for adaptive time step scheme
-
- DEALLOCATE(max_vert_cfl_tmp)
- DEALLOCATE(max_horiz_cfl_tmp)
-
- CALL wrf_debug ( 200 , ' call end of solve_em' )
-
-! Are we about to read SST input from the wrflowinput file? That data is saved
-! for use in fractional merging of external/coupled SST and input SST.
- IF ( coupler_on ) grid%just_read_auxinput4 = Is_alarm_tstep(grid%domain_clock, grid%alarms(AUXINPUT4_ALARM))
-
-! Are we about to read the lateral boundary file? This is a domain one action only.
- IF ( grid%id .EQ. 1 ) grid%just_read_boundary = Is_alarm_tstep(grid%domain_clock, grid%alarms(BOUNDARY_ALARM))
-
-! Finish timers if compiled with -DBENCH.
-#include "bench_solve_em_end.h"
-
-#if (WRF_CMAQ == 1)
- if (firstime) then
- CALL nl_get_wrf_cmaq_option ( 1, wrf_cmaq_option )
- CALL nl_get_wrf_cmaq_freq ( 1, wrf_cmaq_freq )
- CALL nl_get_direct_sw_feedback ( .false., direct_sw_feedback )
- CALL nl_get_met_file_tstep ( 1, met_file_tstep )
-
- cmaq_wrf_feedback = direct_sw_feedback
-
- if (wrf_cmaq_option .gt. 0) then
- cmaq_nstep = ((grid%run_days * 24 + grid%run_hours) * 3600 + grid%run_minutes * 60 + grid%run_seconds) / &
- (grid%time_step * WRF_CMAQ_FREQ)
-
- wrf_end_step = cmaq_nstep * WRF_CMAQ_FREQ - 1
- end if
- end if
-
- if (wrf_cmaq_option .gt. 0) then
- COUNTER = COUNTER + 1
-
- if ( .not. cmaq_wrf_feedback .and. firstime) then
- grid%prev_rainnc = 0.0
- grid%prev_rainc = 0.0
- end if
-
- CMAQ_STEP = (mod(COUNTER, WRF_CMAQ_FREQ) .EQ. 0)
-
- if (CMAQ_STEP) then
- CALL aqprep (grid, config_flags, grid%t_phy, p_phy, &
- grid%rho, grid%z_at_w, dz8w, p8w, t8w, &
- model_config_rec%num_land_cat, 'V4.1.1', &
- wrf_cmaq_option, wrf_cmaq_freq, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- moist(:,:,:,p_qv), & ! optional
- moist(:,:,:,p_qc), & ! optional
- moist(:,:,:,p_qr), & ! optional
- moist(:,:,:,p_qi), & ! optional
- moist(:,:,:,p_qs), & ! optional
- moist(:,:,:,p_qg) & ! optional
- )
- grid%prev_rainnc = grid%rainnc
- grid%prev_rainc = grid%rainc
- end if
-
- if ((counter >= 1) .and. (CMAQ_STEP) .and. (wrf_cmaq_option .gt. 1)) then
-
- CALL CMAQ_DRIVER (cmaq_sdate, cmaq_stime, grid%time_step*WRF_CMAQ_FREQ, &
- twoway_jdate, twoway_jtime, .false.)
-
- if (direct_sw_feedback) then
- CALL FEEDBACK_READ (grid, twoway_jdate, twoway_jtime)
- feedback_is_ready = .true.
- end if
-
- end if
-
-! call aqprep and cmaq one last time before the entire twoway model ends
- if (wrf_end_step == counter) then
- CALL aqprep (grid, config_flags, grid%t_phy, p_phy, &
- grid%rho, grid%z_at_w, dz8w, p8w, t8w, &
- model_config_rec%num_land_cat, 'V4.1.1', &
- wrf_cmaq_option, wrf_cmaq_freq, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- moist(:,:,:,p_qv), & ! optional
- moist(:,:,:,p_qc), & ! optional
- moist(:,:,:,p_qr), & ! optional
- moist(:,:,:,p_qi), & ! optional
- moist(:,:,:,p_qs), & ! optional
- moist(:,:,:,p_qg) & ! optional
- )
-
- if (wrf_cmaq_option .gt. 1) then
-
- CALL CMAQ_DRIVER (cmaq_sdate, cmaq_stime, grid%time_step*WRF_CMAQ_FREQ, &
- twoway_jdate, twoway_jtime, .true.)
- end if
-
- end if
-
- end if
- firstime = .false.
-#endif
-
- RETURN
-
-END SUBROUTINE solve_em
diff --git a/UTIL/wrfcmaq_twoway_coupler/dyn_nmm/module_PHYSICS_CALLS.F b/UTIL/wrfcmaq_twoway_coupler/dyn_nmm/module_PHYSICS_CALLS.F
deleted file mode 100644
index 88e5915396..0000000000
--- a/UTIL/wrfcmaq_twoway_coupler/dyn_nmm/module_PHYSICS_CALLS.F
+++ /dev/null
@@ -1,3648 +0,0 @@
-!-----------------------------------------------------------------------
-!
-!NCEP_MESO:MODEL_LAYER: PHYSICS
-!
-!-----------------------------------------------------------------------
-#include "nmm_loop_basemacros.h"
-#include "nmm_loop_macros.h"
-!-----------------------------------------------------------------------
-!
- MODULE MODULE_PHYSICS_CALLS
-!
-!-----------------------------------------------------------------------
- USE MODULE_DOMAIN
- USE MODULE_DM
- USE MODULE_CONFIGURE
- USE MODULE_TILES
- USE MODULE_STATE_DESCRIPTION,ONLY : P_QV,P_QC,P_QR,P_QI,P_QS,P_QG,P_QNI,P_QNR
- USE MODULE_MODEL_CONSTANTS
- USE MODULE_RA_GFDLETA,ONLY : CAL_MON_DAY,ZENITH
- USE MODULE_RADIATION_DRIVER
- USE MODULE_SF_MYJSFC
- USE MODULE_SURFACE_DRIVER
- USE MODULE_PBL_DRIVER
- USE MODULE_GWD
- USE MODULE_CU_BMJ
- USE MODULE_CUMULUS_DRIVER
- USE MODULE_MP_ETANEW
- USE MODULE_MICROPHYSICS_DRIVER
- USE MODULE_MICROPHYSICS_ZERO_OUT
-!-----------------------------------------------------------------------
-!
- CONTAINS
-!
-!-----------------------------------------------------------------------
-!***********************************************************************
- SUBROUTINE QITEND_FER_HIRES_ADVECT(QI,QRIMEF,QITEND)
- IMPLICIT NONE
- REAL, INTENT(INOUT) :: QI, QRIMEF
- REAL, INTENT(IN) :: QITEND
- REAL :: F_RIMEF
- real, parameter :: max_f_rimef = 60.0, min_f_rimef=1.0
-
- ! For the advected Ferrier-Aligo, we have to handle the QRIMEF
- ! during tendency updates.
-
- ! Determine old rime factor from old QI and old QRIMEF:
- IF(QI0.)THEN
- CZMEAN(I,J)=CZMEAN(I,J)+CZEN(I,J)
- TOT(I,J)=TOT(I,J)+1.
- ENDIF
- ENDDO
- ENDDO
-!
- ENDDO
-!
-!$omp parallel do &
-!$omp& private(i,j)
- DO J=MYJS,MYJE
- DO I=MYIS,MYIE
- IF(TOT(I,J)>0.)CZMEAN(I,J)=CZMEAN(I,J)/TOT(I,J)
- ENDDO
- ENDDO
-!
-!-----------------------------------------------------------------------
-!*** COMPUTE TOTAL SFC SHORTWAVE DOWN FOR NON-GFDL SCHEMES
-!-----------------------------------------------------------------------
-!
-!$omp parallel do &
-!$omp& private(i,j)
- DO J=MYJS2,MYJE2
- DO I=MYIS1,MYIE1
-!
- IF(HBM2(I,J)>0.5)THEN
- TOTSWDN(I,J)=SWNETDN(I,J)/(1.-ALBEDO(I,J))
-!
-!--- No value currently available for clear-sky solar fluxes from
-! non GFDL schemes, though it's needed for air quality forecasts.
-! For the time being, set to the total downward solar fluxes.
-!
- TOTSWDNC(I,J)=TOTSWDN(I,J)
- ENDIF
-!
- ENDDO
- ENDDO
-!
- ENDIF !End non-GFDL block
-!-----------------------------------------------------------------------
-!
-!$omp parallel do &
-!$omp& private(i,iendx,j)
- DO J=MYJS2,MYJE2
- IENDX=MYIE1
- IF(MOD(J,2)==0.AND.ITE==IDE)IENDX=IENDX-1
- DO I=MYIS1,IENDX
-!
- RSWIN(I,J)=TOTSWDN(I,J)
- RSWINC(I,J)=TOTSWDNC(I,J)
- RSWOUT(I,J)=TOTSWDN(I,J)-SWNETDN(I,J)
-!
- ENDDO
- ENDDO
-!
-!$omp parallel do &
-!$omp& private(i,iendx,j,k)
- DO J=MYJS2,MYJE2
- IENDX=MYIE1
- IF(MOD(J,2)==0.AND.ITE==IDE)IENDX=IENDX-1
- DO I=MYIS1,IENDX
- DO K=KTS,KTE
- RSWTT(I,J,K)=THRATENSW(I,K,J)*PI_PHY(I,K,J)
- ENDDO
-!
- ENDDO
- ENDDO
-!
- ENDIF nrads_block
-!
-!-----------------------------------------------------------------------
-!*** LONGWAVE
-!-----------------------------------------------------------------------
-!
- nradl_block: IF(MOD(NTSD,NRADL)==0)THEN
-!
-!$omp parallel do &
-!$omp& private(i,iendx,j)
- DO J=MYJS2,MYJE2
- IENDX=MYIE1
- IF(MOD(J,2)==0.AND.ITE==IDE)IENDX=IENDX-1
- DO I=MYIS1,IENDX
-!
- IF(HBM2(I,J)>0.5)THEN
- TDUM=T(I,J,KTS)
- SIGT4(I,J)=STBOLT*TDUM*TDUM*TDUM*TDUM
- RLWIN(I,J)=TOTLWDN(I,J)
- ENDIF
-!
- ENDDO
- ENDDO
-!
-!$omp parallel do &
-!$omp& private(i,iendx,j,k)
- DO J=MYJS2,MYJE2
- IENDX=MYIE1
- IF(MOD(J,2)==0.AND.ITE==IDE)IENDX=IENDX-1
-!
- DO K=KTS,KTE
- DO I=MYIS1,IENDX
- IF(HBM2(I,J)>0.5)THEN
- RLWTT(I,J,K)=THRATENLW(I,K,J)*PI_PHY(I,K,J)
- ENDIF
- ENDDO
- ENDDO
-!
- ENDDO
-!
- ENDIF nradl_block
-!
-!-----------------------------------------------------------------------
-!*** STORE 3D CLOUD FRACTIONS.
-!-----------------------------------------------------------------------
-!
-!$omp parallel do &
-!$omp& private(i,iendx,j,k)
- DO K=KTS,KTE
- DO J=MYJS2,MYJE2
- IENDX=MYIE1
- IF(MOD(J,2)==0.AND.ITE==IDE)IENDX=IENDX-1
- DO I=MYIS1,IENDX
- CLDFRA(I,J,K)=CLFR(I,K,J)
- ENDDO
- ENDDO
- ENDDO
-!
-!-----------------------------------------------------------------------
-!*** RESET THE DIAGNOSTIC CONVECTIVE CLOUD TOPS/BOTTOMS AFTER
-!*** EACH RADIATION CALL.
-!-----------------------------------------------------------------------
-!
-!$omp parallel do &
-!$omp& private(i,iendx,j)
-!if (config_flags%ra_sw_physics/=hwrfswscheme.and.config_flags%ra_lw_physics/=hwrflwscheme)then
- DO J=MYJS2,MYJE2
- IENDX=MYIE1
- IF(MOD(J,2)==0.AND.ITE==IDE)IENDX=IENDX-1
- DO I=MYIS1,IENDX
- HBOT(I,J)=HBOTR(I,J)
- HTOP(I,J)=HTOPR(I,J)
- CUPPT(I,J)=CUPPTR(I,J)
- ENDDO
- ENDDO
-!endif
-!
-!-----------------------------------------------------------------------
-!*** ZERO OUT BOUNDARY ROWS.
-!-----------------------------------------------------------------------
-!
- DO J=JTS,JTE
- DO I=ITS,ITE
- IF(HBM2(I,J)<0.5)THEN
- ACFRST(I,J)=0.
- ACFRCV(I,J)=0.
- CFRACL(I,J)=0.
- CFRACM(I,J)=0.
- CFRACH(I,J)=0.
- RSWTOA(I,J)=0.
- RLWTOA(I,J)=0.
- ENDIF
- ENDDO
- ENDDO
-!
-!
-!-----------------------------------------------------------------------
-!*** UPDATE THE PROGNOSTIC MOIST ARRAY.
-!-----------------------------------------------------------------------
-!
- DO N=2,N_MOIST
-!$omp parallel do &
-!$omp& private(i,j,k)
- DO J=JMS,JME
- DO K=KMS,KME
- DO I=IMS,IME
- MOIST(I,J,K,N)=MOIST_TRANS(I,K,J,N)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-!
- DEALLOCATE(MOIST_TRANS,STAT=ISTAT)
-!
-!-----------------------------------------------------------------------
-!
- END SUBROUTINE RADIATION
-!
-!-----------------------------------------------------------------------
-!***********************************************************************
-!-----------------------------------------------------------------------
- SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT &
- & ,N_MOIST,N_SCALAR,NSOIL,SLDPTH,DZSOIL &
- & ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2,PDTOP,PT &
- & ,SM,HBM2,VBM2,DX_ARRAY,DFRLG &
- & ,CZEN,CZMEAN,SIGT4,RLWIN,RSWIN,RADOT &
-!- RLWIN/RSWIN - downward longwave/shortwave at the surface (also TOTLWDN/TOTSWDN in RADIATION)
- & ,PD,RES,PINT,T,Q,CWM,F_ICE,F_RAIN,SR &
- & ,Q2,U,V,THS,TSFC,SST,PREC,SNO &
- & ,SCURX,SCURY &
- & ,FIS,Z0,MZ0,Z0BASE,USTAR,MIXHT,PBLH,LPBL,EL_MYJ & !MZ0: MOMENTUM Z0 (KWON)
- & ,MOIST,SCALAR,RMOL,MOL &
- & ,EXCH_H,EXCH_M,F,AKHS,AKMS,AKHS_OUT,AKMS_OUT &
- & ,THZ0,QZ0,UZ0,VZ0,QS,MAVAIL &
- & ,STC,SMC,CMC,SMSTAV,SMSTOT,SSROFF,BGROFF &
- & ,IVGTYP,ISLTYP,VEGFRC,SHDMIN,SHDMAX,GRNFLX &
- & ,SNOTIME &
- & ,SFCEXC,ACSNOW,ACSNOM,SNOPCX,SICE,TG,SOILTB &
- & ,ALBSI,ICEDEPTH,SNOWSI &
- & ,ALBASE,MXSNAL,ALBEDO,SH2O,SI,EPSR,EMBCK &
- & ,U10,V10,UOCE,VOCE,TH10,Q10,TSHLTR,QSHLTR,PSHLTR &
- & ,T2,QSG,QVG,QCG,SOILT1,TSNAV,SMFR3D,KEEPFR3DFLAG &
- & ,TWBS,QWBS,TAUX,TAUY,SFCSHX,SFCLHX,SFCEVP,RTHRATEN&
- & ,POTEVP,POTFLX,SUBSHX &
- & ,APHTIM,ARDSW,ARDLW,ASRFC &
- & ,RSWOUT,RSWTOA,RLWTOA &
- & ,ASWIN,ASWOUT,ASWTOA,ALWIN,ALWOUT,ALWTOA &
- & ,UZ0H,VZ0H,DUDT,DVDT,UGWDsfc,VGWDsfc,SFENTH & ! GWD
- & ,RTHBLTEN,RQVBLTEN &
- & ,PCPFLG,DDATA & ! PRECIP ASSIM
- & ,HSTDV,HCNVX,HASYW,HASYS,HASYSW,HASYNW,HLENW & ! GWD
- & ,HLENS,HLENSW,HLENNW,HANGL,HANIS,HSLOP,HZMAX & ! GWD
- & ,CROT,SROT & ! GWD
- & ,DEW & ! RUC LSM
- & ,RC_MF & ! QNSE
- & ,GRID,CONFIG_FLAGS &
- & ,IHE,IHW,IVE,IVW &
- & ,DISHEAT,DKU3D,DKT3D &
- & ,HPBL2D, EVAP2D, HEAT2D,RC2D & !Kwon S&P
- & ,SFCHEADRT,INFXSRT,SOLDRAIN & !Hydrology, no-op right now
- & ,cd_out,ch_out &
- & ,ulowl, vlowl &
- & ,zkmax, ribn &
- & ,charn, msang &
- & ,DUBLDT,DVBLDT,DTHBLDT,DQVBLDT &
- & ,hpbl_hold &
- & ,IDS,IDE,JDS,JDE,KDS,KDE &
- & ,IMS,IME,JMS,JME,KMS,KME &
- & ,IPS,IPE,JPS,JPE,KPS,KPE &
- & ,ITS,ITE,JTS,JTE,KTS,KTE)
-!***********************************************************************
-!$$$ SUBPROGRAM DOCUMENTATION BLOCK
-! . . .
-! SUBPROGRAM: TURBL TURBULENCE OUTER DRIVER
-! PRGRMMR: BLACK ORG: W/NP22 DATE: 02-04-19
-!
-! ABSTRACT:
-! TURBL DRIVES THE TURBULENCE SCHEMES
-!
-! PROGRAM HISTORY LOG (with changes to called routines) :
-! 95-03-15 JANJIC - ORIGINATOR OF THE SUBROUTINES CALLED
-! BLACK & JANJIC - ORIGINATORS OF THE DRIVER
-! 95-03-28 BLACK - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL
-! 96-03-29 BLACK - ADDED EXTERNAL EDGE; REMOVED SCRCH COMMON
-! 96-07-19 MESINGER - ADDED Z0 EFFECTIVE
-! 98-??-?? TUCCILLO - MODIFIED FOR CLASS VIII PARALLELISM
-! 98-10-27 BLACK - PARALLEL CHANGES INTO MOST RECENT CODE
-! 02-01-10 JANJIC - MOIST TURBULENCE (DRIVER, MIXLEN, VDIFH)
-! 02-01-10 JANJIC - VERT. DIF OF Q2 INCREASED (Grenier & Bretherton)
-! 02-02-02 JANJIC - NEW SFCDIF
-! 02-04-19 BLACK - ORIGINATOR OF THIS OUTER DRIVER FOR WRF
-! 02-05-03 JANJIC - REMOVAL OF SUPERSATURATION AT 2m AND 10m
-! 04-11-18 BLACK - THREADED
-! 05-12-15 BLACK - CONVERTED FROM IKJ TO IJK
-! 07-05-15 FERRIER - ADDED GRAVITY WAVE DRAG (GWD) & MOUNTAIN BLOCKING
-!
-! USAGE: CALL TURBL FROM SOLVE_NMM
-!
-! ATTRIBUTES:
-! LANGUAGE: FORTRAN 90
-! MACHINE : IBM
-!$$$
-!-----------------------------------------------------------------------
-!
- IMPLICIT NONE
-!
-!-----------------------------------------------------------------------
-!
-#if (NMM_CORE==1)
- LOGICAL,INTENT(IN) :: DISHEAT ! hwrf's doing
-#endif
- INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
- & ,IMS,IME,JMS,JME,KMS,KME &
- & ,IPS,IPE,JPS,JPE,KPS,KPE &
- & ,ITS,ITE,JTS,JTE,KTS,KTE &
- & ,N_MOIST,NPHS,NSOIL,NTSD,N_SCALAR
-!
- INTEGER, DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
-!
- INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ISLTYP,IVGTYP
-!
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: HPBL2D, EVAP2D, HEAT2D , RC2D !Kwon S&P
-!
- INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: LPBL
-!
- REAL,INTENT(IN) :: DT,PDTOP,PT
-!
- REAL,INTENT(IN) :: SFENTH
- REAL,INTENT(INOUT) :: APHTIM,ARDSW,ARDLW,ASRFC
-!
- REAL,DIMENSION(KMS:KME-1),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
-!
- REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: RTHRATEN !Kwon S&P
-!
- REAL,DIMENSION(KMS:KME),INTENT(IN) :: DFRLG,ETA1,ETA2
-!
- REAL,DIMENSION(NSOIL),INTENT(IN) :: DZSOIL,SLDPTH
-!
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: CZEN,CZMEAN &
- & ,DX_ARRAY &
- & ,F,FIS,HBM2 &
- & ,PD,RES &
- & ,RLWIN,RLWTOA &
- & ,RSWIN,RSWOUT,RSWTOA &
- & ,SHDMIN,SHDMAX &
-! & ,SICE,SIGT4,SM,SR & !Bandaid
- & ,SIGT4 &
- & ,HSTDV,HCNVX,HASYW,HASYS,HASYSW,HASYNW,HLENW & ! GWD
- & ,HLENS,HLENSW,HLENNW,HANGL,HANIS,HSLOP,HZMAX & ! GWD
- & ,CROT,SROT & ! GWD
- & ,VBM2,VEGFRC
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: SST
- REAL,DIMENSION(IMS:IME,JMS:JME) :: ALBSI
- REAL,DIMENSION(IMS:IME,JMS:JME) :: ICEDEPTH
- REAL,DIMENSION(IMS:IME,JMS:JME) :: SNOWSI
-!
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: SM,EPSR,SR & !Bandaid
- ,TG,SICE &
- ,EMBCK
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ALBASE,MXSNAL
-!
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ACSNOM,ACSNOW &
- & ,SNOTIME &
- & ,AKHS,AKMS &
- & ,ALBEDO &
- & ,BGROFF,CMC &
- & ,MAVAIL,MOL &
- & ,MIXHT &
- & ,PBLH,POTEVP &
- & ,POTFLX,PREC &
- & ,QCG,QS,QSG &
- & ,QVG,QZ0 &
- & ,RMOL &
- & ,SFCEVP &
- & ,SFCLHX,SFCSHX &
- & ,SI,SMSTOT &
- & ,SNO,SNOPCX &
- & ,SOILT1 &
- & ,SSROFF,SUBSHX &
- & ,T2,THS,THZ0 &
- & ,TSFC,TSNAV &
- & ,USTAR,UZ0,UZ0H &
- & ,VZ0,VZ0H &
- & ,DEW & !RUC LSM
- & ,Z0,MZ0,Z0BASE !MZ0 (KWON)
-!
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: AKHS_OUT,AKMS_OUT &
- & ,ALWIN,ALWOUT &
- & ,ALWTOA,ASWIN &
- & ,ASWOUT,ASWTOA &
- & ,PSHLTR,Q10,QSHLTR &
- & ,TH10,TSHLTR &
- & ,U10,V10 & ! GWD
- & ,UOCE,VOCE &
- & ,UGWDsfc,VGWDsfc ! GWD
-!
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: GRNFLX,QWBS,RADOT &
- ,SFCEXC,SMSTAV &
- ,SOILTB,TWBS
-!
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: scurx, scury
-
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: cd_out,ch_out
- REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: &
- DTHBLDT &
- ,DQVBLDT &
- ,DUBLDT &
- ,DVBLDT
-
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: taux, tauy
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: zkmax, ribn
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: charn, msang
- REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: PINT
-!
- REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: CWM &
- & ,DUDT &
- & ,DVDT &
- & ,Q,Q2 &
- & ,T,U,V
-!
- REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: F_ICE & !<--- Used only in physics (IKJ)
- & ,F_RAIN &
- & ,RQVBLTEN &
- & ,RTHBLTEN
-!
- REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) :: EL_MYJ & !<--- Used only in physics (IKJ)
- & ,EXCH_H &
- & ,EXCH_M
-!
- REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(OUT) :: DKU3D,DKT3D ! KWON
- REAL,DIMENSION(IMS:IME,NSOIL,JMS:JME),INTENT(INOUT) :: KEEPFR3DFLAG & !<--- Used only in physics (IKJ)
- & ,SH2O,SMC &
- & ,SMFR3D,STC
-
- REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: RC_MF ! QNSE only
-!
- REAL,DIMENSION(IMS:IME,NSOIL,JMS:JME) :: SMCREL
-!
- REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,N_MOIST) &
- & ,INTENT(INOUT) :: MOIST
-!
- REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,N_SCALAR) &
- & ,INTENT(INOUT) :: SCALAR
-!
- LOGICAL,INTENT(IN) :: RESTRT
-!
- TYPE(DOMAIN),TARGET :: GRID
-!
- TYPE(GRID_CONFIG_REC_TYPE),INTENT(IN) :: CONFIG_FLAGS
-!
-! For precip assimilation:
- LOGICAL,INTENT(IN) :: PCPFLG
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DDATA
-
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: SFCHEADRT ! Hydrology, no-op right now
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: INFXSRT,SOLDRAIN ! Hydrology, no-op right now
-!
-!-----------------------------------------------------------------------
-!***
-!*** LOCAL VARIABLES
-!***
-!-----------------------------------------------------------------------
- INTEGER :: I,I_M,IDUMMY,IEND,ISFFLX,ISTAT,ISTR,J,K,KOUNT_ALL &
- & ,LENGTH_ROW,LLIJ,LLYR,N,SST_UPDATE,SF_URBAN_PHYSICS,NUM_URBAN_LAYERS
- INTEGER :: FASDAS
-!
- INTEGER,DIMENSION(IMS:IME,JMS:JME) :: KPBL,LOWLYR
-!
- REAL :: TRESH=0.95
-!
- REAL :: ALTITUDE,CWML,DQDT,DTDT,DTPHS,DX,DZHALF,FACTR,FACTRL &
- & ,G_INV,PLYR,PSFC,QI,QL,QOLD,QR,QW,RATIOMX,RDTPHS,DY &
- & ,ROG,RWMSK,SDEPTH,SNO_FACTR,TL,TLMH,TLMH4,TNEW,TSFC2 &
- & ,U_FRAME,V_FRAME,XLVRW
-!
- REAL :: APES,CAPA,CKLQ,EXNER,FACTOR,FFS,PQ0X,Q2SAT,QFC1,QLOWX &
- & ,RLIVWV,THBOT,DPL
-!
- REAL,DIMENSION(IMS:IME,JMS:JME) :: BR,CHKLOWQ,CT,CWMLOW,ELFLX &
- & ,EXNSFC,FACTRS,FLHC,FLQC,GZ1OZ0 &
- & ,FH,FM,ZOL &
- & ,ONE,PDSL,PLM,PSFC_OUT,PSIH &
- & ,PSIM,Q2X,QLOW,RAIN,RAINBL &
- & ,RLW_DN_SFC,RSW_NET_SFC &
- & ,RSW_DN_SFC &
- & ,SFCEVPX,SFCZ,SNOW,SNOWC,SNOWH &
- & ,TH2X,THLOW,TLOW,VGFRCK &
- & ,RS,XLAIDYN &
- & ,WSPD,XLAND,REGIME,HOL
-!
- REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: DUDT_PHY,DVDT_PHY,DZ &
- & ,P_PHY,P8W,PI_PHY &
- & ,RQCBLTEN,RQIBLTEN &
-!BSF & ,RQSBLTEN,RQRBLTEN,RQGBLTEN &
- & ,RR,DELP & ! GWD
- & ,T_PHY,TH_PHY,TKE &
- & ,DUDT_GWD,DVDT_GWD & ! GWD
- & ,U_PHY,V_PHY,Z
-!
- REAL,DIMENSION(IMS:IME,JMS:JME), INTENT(OUT) :: ULOWL, VLOWL
-!
- REAL,DIMENSION(:,:,:,:),ALLOCATABLE :: MOIST_TRANS
-!
- REAL,DIMENSION(IMS:IME,NSOIL,JMS:JME) :: ZERO_SOIL
-!
- REAL,DIMENSION(IMS:IME,JMS:JME) :: wstar_ysu, delta_ysu
- REAL,DIMENSION(IMS:IME,JMS:JME) :: hpbl_hold
-!
- LOGICAL :: E_BDY,WARM_RAIN
- LOGICAL :: IS_CAMMGMP_USED=.FALSE.
-!
- INTEGER :: NUM_ROOF_LAYERS,NUM_WALL_LAYERS,NUM_ROAD_LAYERS ! urban
- INTEGER :: FRACTIONAL_SEAICE
- INTEGER :: SEAICE_ALBEDO_OPT
- REAL :: SEAICE_ALBEDO_DEFAULT
- INTEGER :: SEAICE_THICKNESS_OPT
- REAL :: SEAICE_THICKNESS_DEFAULT
- INTEGER :: SEAICE_SNOWDEPTH_OPT
- REAL :: SEAICE_SNOWDEPTH_MAX
- REAL :: SEAICE_SNOWDEPTH_MIN
- INTEGER :: IFNDALBSI
- INTEGER :: IFNDICEDEPTH
- INTEGER :: IFNDSNOWSI
- REAL :: WIND
- INTEGER :: IGS,IGE,JGS,JGE, PQ_I !BSF
- LOGICAL :: FQ_I, ETAMP_PHYSICS,ETAMP_Regional !BSF
-
- CHARACTER(len=255) :: message
-#if HWRF==1
-!dbg integer :: kpblmin,kpblmax,lpblmin,lpblmax !dbg
- logical :: pert_pbl
- logical :: pert_Cd
- real :: ens_Cdamp
- real :: ens_pblamp
- integer :: ens_random_seed
-#endif
-!
-!
- TYPE(WRFU_Time) :: currentTime
- INTEGER :: yr, month, day, hr, minute, sec, rc
- CHARACTER*80 :: mesg
-
- INTEGER :: isurban
- CHARACTER(len=256) :: MMINLU
- REAL :: VAR_RIC,coef_ric_s,coef_ric_l !KWON for variable Ric (=1)
-!-----------------------------------------------------------------------
-!***********************************************************************
-!-----------------------------------------------------------------------
-!
- ALLOCATE(MOIST_TRANS(IMS:IME,KMS:KME,JMS:JME,N_MOIST),STAT=ISTAT)
-!
- SF_URBAN_PHYSICS=CONFIG_FLAGS%SF_URBAN_PHYSICS
- FASDAS=0
-
- if ( config_flags%bl_pbl_physics == BOULACSCHEME ) then
- call wrf_error_fatal("Cannot use BOULAC PBL with NMM")
- endif
-
- FRACTIONAL_SEAICE = CONFIG_FLAGS%FRACTIONAL_SEAICE
- IF ( FRACTIONAL_SEAICE == 1 ) THEN
- CALL WRF_ERROR_FATAL("NMM cannot use FRACTIONAL_SEAICE = 1.")
- ENDIF
-
- SEAICE_ALBEDO_OPT = CONFIG_FLAGS%SEAICE_ALBEDO_OPT
- IF ( SEAICE_ALBEDO_OPT /= 0 ) THEN
- CALL WRF_ERROR_FATAL("NMM must use SEAICE_ALBEDO_OPT = 0")
- ENDIF
-
- IFNDALBSI = 0
- IFNDSNOWSI = 0
- IFNDICEDEPTH = 0
- BR=10
-
- SEAICE_ALBEDO_DEFAULT = CONFIG_FLAGS%SEAICE_ALBEDO_DEFAULT
- SEAICE_THICKNESS_OPT = CONFIG_FLAGS%SEAICE_THICKNESS_OPT
- SEAICE_THICKNESS_DEFAULT = CONFIG_FLAGS%SEAICE_THICKNESS_DEFAULT
- SEAICE_SNOWDEPTH_OPT = CONFIG_FLAGS%SEAICE_SNOWDEPTH_OPT
- SEAICE_SNOWDEPTH_MAX = CONFIG_FLAGS%SEAICE_SNOWDEPTH_MAX
- SEAICE_SNOWDEPTH_MIN = CONFIG_FLAGS%SEAICE_SNOWDEPTH_MIN
-!
- DTPHS=NPHS*DT
- RDTPHS=1./DTPHS
- G_INV=1./G
- ROG=R_D*G_INV
- FACTOR=-XLV*RHOWATER/DTPHS
- CAPA=R_D/CP
-!
- U_FRAME=0.
- V_FRAME=0.
-!
- IDUMMY=0
- ISFFLX=1
- DX=0.
- DY=0.
- SST_UPDATE=config_flags%SST_UPDATE
-!
-!$omp parallel do &
-!$omp& private(i,j)
- DO J=JMS,JME
- DO I=IMS,IME
- UZ0H(I,J)=0.
- VZ0H(I,J)=0.
- ONE(I,J)=1.
- RMOL(I,J)=0. !Reciprocal of Monin-Obukhov length
- SFCEVPX(I,J)=0. !Dummy for accumulated latent energy, not flux
- ZOL(I,J)=0.
- ENDDO
- ENDDO
-!
- IF(MODEL_CONFIG_REC%SF_SURFACE_PHYSICS(GRID%ID)==99)THEN
- SNO_FACTR=1.
- ELSE
- SNO_FACTR=0.001
- ENDIF
-!
-!$omp parallel do &
-!$omp& private(i,j)
- DO J=MYJS,MYJE
- DO I=MYIS,MYIE
- LOWLYR(I,J)=1
- VGFRCK(I,J)=100.*VEGFRC(I,J)
- SNOW(I,J)=SNO(I,J)
- SNOWH(I,J)=SI(I,J)*SNO_FACTR
- XLAND(I,J)=SM(I,J)+1.
- T2(I,J)=TSFC(I,J)
- ENDDO
- ENDDO
-!
- IF(NTSD==0)THEN
-!$omp parallel do &
-!$omp& private(i,j)
- DO J=MYJS,MYJE
- DO I=MYIS,MYIE
- Z0BASE(I,J)=Z0(I,J)
- IF(SM(I,J)>0.5.AND.SICE(I,J)>0.5)THEN !Bandaid
- SM(I,J)=0.
- ENDIF
- ENDDO
- ENDDO
- ENDIF
-!
-!$omp parallel do &
-!$omp& private(i,j,k)
- DO J=MYJS,MYJE
- DO K=KTS,KTE+1
- DO I=MYIS,MYIE
- Z(I,K,J)=0.
- DZ(I,K,J)=0.
- EXCH_H(I,K,J)=0.
- EXCH_M(I,K,J)=0.
- ENDDO
- ENDDO
- ENDDO
-!
-!-----------------------------------------------------------------------
-!
-!*** PREPARE NEEDED ARRAYS FOR CALLING THE INNER DRIVER.
-!
-!-----------------------------------------------------------------------
-!
-!$omp parallel do &
-!$omp& private(factrl,i,j,llij,tlmh)
- DO J=MYJS,MYJE
- DO I=MYIS,MYIE
-!
- PDSL(I,J)=PD(I,J)*RES(I,J)
-!!! PSFC=PD(I,J)+PDTOP+PT
-!!! P8W(I,KTS,J)=PSFC
- P8W(I,KTS,J)=PINT(I,J,KTS)
- PSFC=PINT(I,J,KTS)
- LOWLYR(I,J)=KTS !<---- The lowest model layer counted from the bottom.
- EXNSFC(I,J)=(1.E5/PSFC)**CAPA
- THS(I,J)=(SST(I,J)*EXNSFC(I,J))*SM(I,J)+THS(I,J)*(1.-SM(I,J))
- TSFC(I,J)=THS(I,J)/EXNSFC(I,J)
- SFCZ(I,J)=FIS(I,J)*G_INV
-!YL RAIN(I,J)=PREC(I,J)*RHOWATER
- IF (PCPFLG.AND.DDATA(I,J)<100.)THEN
- RAIN(I,J)=DDATA(I,J)*RHOWATER
- ELSE
- RAIN(I,J)=PREC(I,J)*RHOWATER
- ENDIF
-!YL
- RAINBL(I,J)=0.
- IF(SNO(I,J)>0.)SNOWC(I,J)=1.
- LLIJ=LOWLYR(I,J)
- PLM(I,J)=(PINT(I,J,LLIJ)+PINT(I,J,LLIJ+1))*0.5
- TH2X(I,J)=T(I,J,LLIJ)*(1.E5/PLM(I,J))**CAPA
- Q2X(I,J)=Q(I,J,LLIJ)
-!
-!-----------------------------------------------------------------------
-!*** LONG AND SHORTWAVE FLUX AT GROUND SURFACE
-!-----------------------------------------------------------------------
-!
- IF(CZMEAN(I,J)>0.)THEN
- FACTRS(I,J)=CZEN(I,J)/CZMEAN(I,J)
- ELSE
- FACTRS(I,J)=0.
- ENDIF
-!
- IF(SIGT4(I,J)>0.)THEN
- TLMH=T(I,J,LLIJ)
- FACTRL=STBOLT*TLMH*TLMH*TLMH*TLMH/SIGT4(I,J)
- ELSE
- FACTRL=0.
- ENDIF
-!
-!- RLWIN/RSWIN - downward longwave/shortwave at the surface
-!
- RLW_DN_SFC(I,J)=RLWIN(I,J)*HBM2(I,J)*FACTRL
- RSW_NET_SFC(I,J)=(RSWIN(I,J)-RSWOUT(I,J))*HBM2(I,J)*FACTRS(I,J)
-!
-!- Instant downward solar for nmm_lsm
-!
- RSW_DN_SFC(I,J)=RSWIN(I,J)*HBM2(I,J)*FACTRS(I,J)
-!
- Z(I,KTS,J)=SFCZ(I,J)
-!
- ENDDO
- ENDDO
-!
-!-----------------------------------------------------------------------
-!*** FILL THE ARRAYS FOR CALLING THE INNER DRIVER.
-!-----------------------------------------------------------------------
-!
-!$omp parallel do &
-!$omp& private(cwml,i,j,k,plyr,qi,ql,qr,qw,tl)
- DO J=MYJS,MYJE
- DO K=KTS,KTE
- DO I=MYIS,MYIE
- Q2(I,J,K)=MAX(Q2(I,J,K)*HBM2(I,J),EPSQ2)
- QL=MAX(Q(I,J,K),EPSQ)
- PLYR=(PINT(I,J,K)+PINT(I,J,K+1))*0.5
-!!! PLYR=AETA1(K)*PDTOP+AETA2(K)*PDSL(I,J)+PT
- TL=T(I,J,K)
- CWML=CWM(I,J,K)
-!
- RR(I,K,J)=PLYR/(R_D*TL)
- T_PHY(I,K,J)=TL
-!
- EXNER=(1.E5/PLYR)**CAPA
- PI_PHY(I,K,J)=1./EXNER
- TH_PHY(I,K,J)=TL*EXNER
- P8W(I,K+1,J)=PINT(I,J,K+1)
-!!! P8W(I,K+1,J)=ETA1(K+1)*PDTOP+ETA2(K+1)*PDSL(I,J)+PT
- P_PHY(I,K,J)=PLYR
- TKE(I,K,J)=0.5*Q2(I,J,K)
-!
- RTHBLTEN(I,K,J)=0.
- RQVBLTEN(I,K,J)=0.
- RQCBLTEN(I,K,J)=0.
- RQIBLTEN(I,K,J)=0.
-!BSF RQSBLTEN(I,K,J)=0.
-!BSF RQRBLTEN(I,K,J)=0.
-!BSF RQGBLTEN(I,K,J)=0.
-!
-!-- Next 3 lines modified for GWD
-!
- DPL=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
- Z(I,K+1,J)=Z(I,K,J)+TL/PLYR*DPL*ROG*(Q(I,J,K)*P608-CWML+1.)
- DELP(I,K,J)=DPL
- DZ(I,K,J)=Z(I,K+1,J)-Z(I,K,J)
- ENDDO
- ENDDO
- ENDDO
-!
-!$omp parallel do &
-!$omp& private(i,j,llyr,qlowx)
- DO J=MYJS,MYJE
- DO I=MYIS,MYIE
- TWBS(I,J)=0.
- QWBS(I,J)=0.
- LLYR=LOWLYR(I,J)
- THLOW(I,J)=TH_PHY(I,LLYR,J)
- TLOW(I,J)=T_PHY(I,LLYR,J)
- QLOW(I,J)=MAX(Q(I,J,LLYR),EPSQ)
- QLOWX=QLOW(I,J)/(1.-QLOW(I,J))
- QLOW(I,J)=QLOWX/(1.+QLOWX)
- CWMLOW(I,J)=CWM(I,J,LLYR)
- PBLH(I,J)=MAX(PBLH(I,J),0.)
- PBLH(I,J)=MIN(PBLH(I,J),Z(I,KTE,J))
- ENDDO
- ENDDO
-!-----------------------------------------------------------------------
-!
-!*** COMPUTE VELOCITY COMPONENTS AT MASS POINTS
-!
-!-----------------------------------------------------------------------
-!$omp parallel do &
-!$omp& private(i,j,k)
- DO K=KTS,KTE
- DO J=MYJS1_P1,MYJE1_P1
- DO I=MYIS_P1,MYIE_P1
- U_PHY(I,K,J)=(U(I+IHE(J),J,K)+U(I+IHW(J),J,K) &
- & +U(I,J+1,K)+U(I,J-1,K)) &
- & *0.25
- V_PHY(I,K,J)=(V(I+IHE(J),J,K)+V(I+IHW(J),J,K) &
- & +V(I,J+1,K)+V(I,J-1,K)) &
- & *0.25
- IF ( K == KTS ) THEN
- ULOWL(I,J) = U_PHY(I,K,J)
- VLOWL(I,J) = V_PHY(I,K,J)
- ENDIF
- ENDDO
- ENDDO
- ENDDO
-!
-!$omp parallel do &
-!$omp& private(i,iend,istr,j)
- DO J=MYJS1_P1,MYJE1_P1
- IF(MOD(J,2)==0)THEN
- ISTR=MYIS_P1
- IEND=MIN(MYIE_P1,IDE-1)
- ELSE
- ISTR=MAX(MYIS_P1,IDS+1)
- IEND=MIN(MYIE_P1,IDE-1)
- ENDIF
-!
- DO I=ISTR,IEND
- UZ0H(I,J)=(UZ0(I+IHE(J),J)+UZ0(I+IHW(J),J) &
- & +UZ0(I,J+1)+UZ0(I,J-1))*0.25
-!!! & +UZ0(I,J+1)+UZ0(I,J-1))*HBM2(I,J)*0.25
- VZ0H(I,J)=(VZ0(I+IHE(J),J)+VZ0(I+IHW(J),J) &
- & +VZ0(I,J+1)+VZ0(I,J-1))*0.25
-!!! & +VZ0(I,J+1)+VZ0(I,J-1))*HBM2(I,J)*0.25
- ENDDO
- ENDDO
-!
-!-----------------------------------------------------------------------
-!*** SET MAVAIL EQUAL TO 1. ONLY FOR NMM LSM
-!-----------------------------------------------------------------------
-!
- DO J=JTS,JTE
- DO I=ITS,ITE
- IF(MODEL_CONFIG_REC%SF_SURFACE_PHYSICS(GRID%ID)==2.OR. &
- MODEL_CONFIG_REC%SF_SURFACE_PHYSICS(GRID%ID)==99)THEN
- ONE(I,J)=1.
- ELSE
-!*** MAVAIL should not be equal to 1. for other LSMs
- ONE(I,J)=MAVAIL(I,J)
- ENDIF
- ENDDO
- ENDDO
-!
-!-----------------------------------------------------------------------
-!*** TRANSPOSE THE MOIST ARRAY (IJK) FOR THE PHYSICS (IKJ).
-!-----------------------------------------------------------------------
-!
- DO N=1,N_MOIST
-!$omp parallel do &
-!$omp& private(i,j,k)
- DO K=KMS,KME
- DO J=JMS,JME
- DO I=IMS,IME
- MOIST_TRANS(I,K,J,N)=MOIST(I,J,K,N)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-!
-!-----------------------------------------------------------------------
-!*** URBAN RELATED VARIABLES ARE ADDED TO ARGUMENTS OF SURFACE_DRIVER
-!-----------------------------------------------------------------------
-!
- NUM_ROOF_LAYERS=GRID%NUM_SOIL_LAYERS !urban
- NUM_WALL_LAYERS=GRID%NUM_SOIL_LAYERS !urban
- NUM_ROAD_LAYERS=GRID%NUM_SOIL_LAYERS !urban
- CALL nl_get_isurban(grid%id, isurban)
- call nl_get_mminlu(grid%id, mminlu)
-
- CALL domain_clock_get( grid, current_time=currentTime, &
- current_timestr=mesg )
- CALL WRFU_TimeGet( currentTime, YY=yr, dayOfYear=day, H=hr, M=minute, S=sec, rc=rc)
- IF( rc/= WRFU_SUCCESS)THEN
- CALL wrf_error_fatal('WRFU_TimeGet failed')
- ENDIF
-
-
-!
-!-----------------------------------------------------------------------
-!
-!*** CALL SURFACE LAYER AND LAND SURFACE PHYSICS
-!
-!-----------------------------------------------------------------------
-!
- CALL SET_TILES(GRID,IDS,IDE-1,JDS+1,JDE-1,ITS,ITE,JTS,JTE)
-
-!
- CALL SURFACE_DRIVER( &
- & HYDRO_dt=-1.0, SFCHEADRT=SFCHEADRT, &
- & INFXSRT=INFXSRT, SOLDRAIN=SOLDRAIN, &
- & JULIAN_IN=grid%julian, &
- & ACSNOM=ACSNOM,ACSNOW=ACSNOW,AKHS=AKHS,AKMS=AKMS &
- & ,ALBEDO=ALBEDO,BR=BR,CANWAT=CMC,CHKLOWQ=CHKLOWQ &
- & ,DT=DT,DX=DX,DZ8W=DZ,DZS=DZSOIL,GLW=RLW_DN_SFC &
- & ,GRDFLX=GRNFLX,GSW=RSW_NET_SFC,SWDOWN=RSW_DN_SFC &
- & ,GZ1OZ0=GZ1OZ0,HFX=TWBS &
- & ,HT=SFCZ,IFSNOW=IDUMMY,ISFFLX=ISFFLX &
- & ,FRACTIONAL_SEAICE=FRACTIONAL_SEAICE &
- & ,SEAICE_ALBEDO_OPT=SEAICE_ALBEDO_OPT &
- & ,SEAICE_ALBEDO_DEFAULT=SEAICE_ALBEDO_DEFAULT &
- & ,SEAICE_THICKNESS_OPT=SEAICE_THICKNESS_OPT &
- & ,SEAICE_THICKNESS_DEFAULT=SEAICE_THICKNESS_DEFAULT &
- & ,SEAICE_SNOWDEPTH_OPT=SEAICE_SNOWDEPTH_OPT &
- & ,SEAICE_SNOWDEPTH_MAX=SEAICE_SNOWDEPTH_MAX &
- & ,SEAICE_SNOWDEPTH_MIN=SEAICE_SNOWDEPTH_MIN &
- & ,TICE2TSK_IF2COLD=CONFIG_FLAGS%TICE2TSK_IF2COLD &
- & ,IFNDALBSI=IFNDALBSI,IFNDICEDEPTH=IFNDICEDEPTH &
- & ,IFNDSNOWSI=IFNDSNOWSI &
- & ,ISLTYP=ISLTYP &
- & ,ITIMESTEP=NTSD,IVGTYP=IVGTYP,LOWLYR=LOWLYR &
- & ,MAVAIL=ONE,RMOL=RMOL,MOL=MOL &
- & ,NUM_SOIL_LAYERS=NSOIL,P8W=P8W &
- & ,PBLH=PBLH,PI_PHY=PI_PHY,PSHLTR=PSHLTR,PSIH=PSIH &
- & ,PSIM=PSIM,P_PHY=P_PHY,Q10=Q10,Q2=Q2X,QFX=QWBS,TAUX=TAUX,TAUY=TAUY,QSFC=QS &
- & ,QSHLTR=QSHLTR,QZ0=QZ0 &
- & ,ICOEF_SF=CONFIG_FLAGS%ICOEF_SF &
- & ,LCURR_SF=CONFIG_FLAGS%LCURR_SF &!for gfdl-sf drag
- & ,ZKMAX=ZKMAX,RIBN=RIBN &
- & ,CHARN=CHARN,MSANG=MSANG,SCURX=SCURX,SCURY=SCURY &
- & ,IWAVECPL=CONFIG_FLAGS%IWAVECPL &
-#if (HWRF==1)
- & ,pert_Cd=config_flags%pert_Cd &
- & ,ens_random_seed=config_flags%ens_random_seed &
- & ,ens_Cdamp=config_flags%ens_Cdamp &
-#endif
- & ,cd_out=grid%cd_out,ch_out=grid%ch_out &
- & ,RAINCV=RAIN &
- & ,RHO=RR,SFCEVP=SFCEVPX,SFCEXC=SFCEXC,SFCRUNOFF=SSROFF &
- & ,SMOIS=SMC,SMSTAV=SMSTAV,SMSTOT=SMSTOT,SNOALB=MXSNAL &
- & ,SNOW=SNOW,SNOWC=SNOWC,SNOWH=SNOWH,STEPBL=NPHS &
- & ,SMCREL=SMCREL &
- & ,SST=SST,SST_UPDATE=SST_UPDATE,MAX_EDOM=-1 &
- & ,TH10=TH10,TH2=TH2X,T2=T2,THZ0=THZ0,TH_PHY=TH_PHY &
- & ,TMN=TG,TSHLTR=TSHLTR,TSK=TSFC,TSLB=STC,T_PHY=T_PHY &
- & ,U10=U10,UDRUNOFF=BGROFF,UST=USTAR,UZ0=UZ0H &
- & ,U_FRAME=U_FRAME,U_PHY=U_PHY,V10=V10,VEGFRA=VGFRCK &
- & ,U10E=grid%U10E,V10E=grid%V10E &
- & ,UOCE=UOCE,VOCE=VOCE &
- & ,VZ0=VZ0H,V_FRAME=V_FRAME,V_PHY=V_PHY &
- & ,WARM_RAIN=WARM_RAIN,WSPD=WSPD,XICE=SICE,XICEM=SICE &
- & ,ALBSI=albsi,ICEDEPTH=icedepth,SNOWSI=snowsi &
- & ,ISICE=GRID%LANDUSE_ISICE,ISWATER=GRID%ISWATER &
- & ,XLAND=XLAND,Z=Z,ZNT=Z0 &
-#if ( HWRF == 1 )
- & ,MZNT=MZ0 &
-#endif
- & ,ZS=SLDPTH,CT=CT,TKE_PBL=TKE,SFENTH=SFENTH & !KWON
- & ,ALBBCK=ALBASE,LH=ELFLX,SH2O=SH2O,SHDMAX=SHDMAX &
- & ,SHDMIN=SHDMIN,Z0=Z0BASE,FLQC=FLQC,FLHC=FLHC &
- & ,FM=FM,FHH=FH,ZOL=ZOL &
- & ,PSFC=PSFC_OUT,EMISS=EPSR,EMBCK=EMBCK &
- & ,SF_SFCLAY_PHYSICS=CONFIG_FLAGS%SF_SFCLAY_PHYSICS &
- & ,BL_PBL_PHYSICS=config_flags%bl_pbl_physics &
- & ,SF_SURFACE_PHYSICS=CONFIG_FLAGS%SF_SURFACE_PHYSICS &
- & ,RA_LW_PHYSICS=CONFIG_FLAGS%RA_LW_PHYSICS &
- & ,RA_SW_PHYSICS=CONFIG_FLAGS%RA_SW_PHYSICS &
- & ,LAI=GRID%LAI,IZ0TLND=CONFIG_FLAGS%IZ0TLND &
- & ,SF_URBAN_PHYSICS=SF_URBAN_PHYSICS &
-! & ,GMT=GMT,XLAT=XLAT,XLONG=XLONG,JULDAY=JULDAY &
- & ,num_urban_ndm = config_flags%num_urban_ndm & !multi-layer urban
- & ,urban_map_zrd = config_flags%urban_map_zrd & !multi-layer urban
- & ,urban_map_zwd = config_flags%urban_map_zwd & !multi-layer urban
- & ,urban_map_gd = config_flags%urban_map_gd & !multi-layer urban
- & ,urban_map_zd = config_flags%urban_map_zd & !multi-layer urban
- & ,urban_map_zdf = config_flags%urban_map_zdf & !multi-layer urban
- & ,urban_map_bd = config_flags%urban_map_bd & !multi-layer urban
- & ,urban_map_wd = config_flags%urban_map_wd & !multi-layer urban
- & ,urban_map_gbd = config_flags%urban_map_gbd & !multi-layer urban
- & ,urban_map_fbd = config_flags%urban_map_fbd & !multi-layer urban
- & ,urban_map_zgrd = config_flags%urban_map_zgrd & !multi-layer urban
- & ,NUM_URBAN_HI=config_flags%num_urban_hi & !multi-layer urban
- & ,IDS=IDS,IDE=IDE,JDS=JDS,JDE=JDE,KDS=KDS,KDE=KDE &
- & ,IMS=IMS,IME=IME,JMS=JMS,JME=JME,KMS=KMS,KME=KME &
- & ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe &
- & ,I_START=GRID%I_START,I_END=GRID%I_END &
- & ,J_START=GRID%J_START,J_END=GRID%J_END &
- & ,KTS=KTS,KTE=KTE,NUM_TILES=GRID%NUM_TILES &
- ! Optional args
- & ,QV_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QV),F_QV=F_QV &
- & ,QC_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QC),F_QC=F_QC &
- & ,QR_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QR),F_QR=F_QR &
- & ,QI_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QI),F_QI=F_QI &
- & ,QS_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QS),F_QS=F_QS &
- & ,QG_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QG),F_QG=F_QG &
- & ,RAINBL=RAINBL &
- & ,LAGDAY=1 & ! tmn_update
-! for RUCLSM
- & ,QSG=QSG,QVG=QVG,QCG=QCG,SOILT1=SOILT1 &
- & ,TSNAV=TSNAV,SMFR3D=SMFR3D,KEEPFR3DFLAG=KEEPFR3DFLAG &
- & ,POTEVP=POTEVP,SNOPCX=SNOPCX,SOILTB=SOILTB,SR=SR &
- & ,DEW=DEW,ACRUNOFF=grid%ACRUNOFF &
- & ,MOSAIC_LU=CONFIG_FLAGS%MOSAIC_LU &
- & ,MOSAIC_SOIL=CONFIG_FLAGS%MOSAIC_SOIL &
- & ,LANDUSEF=grid%landusef &
- & ,SOILCTOP=grid%soilctop &
- & ,rhosnf=grid%rhosnf,precipfr=grid%precipfr &
- & ,snowfallac=grid%snowfallac &
-! for URBAN
- & ,NUM_ROOF_LAYERS=NUM_ROOF_LAYERS & ! urban
- & ,NUM_WALL_LAYERS=NUM_WALL_LAYERS & ! urban
- & ,NUM_ROAD_LAYERS=NUM_ROAD_LAYERS & ! urban
-! for YSU
- & ,REGIME=REGIME &
-! for PX LSM
- & ,NLCAT=grid%num_land_cat, NSCAT=grid%num_soil_cat & ! P-X LSM
- & ,ISURBAN=isurban, MMINLU=TRIM(mminlu) &
- & ,SNOTIME = grid%SNOTIME &
- & ,RDLAI2D=config_flags%rdlai2d &
- & ,usemonalb=config_flags%usemonalb &
- & ,NOAHRES=grid%noahres &
- & ,opt_thcnd=config_flags%opt_thcnd &
-! for Noah UA changes
- & ,ua_phys=config_flags%ua_phys,flx4=grid%flx4,fvb=grid%fvb &
- & ,fbur=grid%fbur,fgsn=grid%fgsn &
-! vertical dimensions for ocean model, not used for NMM
- & ,okms = 1, okme=2 &
-! for NOAH-MP LSM
- & ,YR=yr &
- & ,idveg=config_flags%dveg, iopt_crs=config_flags%opt_crs &
- & ,iopt_btr=config_flags%opt_btr, iopt_run=config_flags%opt_run &
- & ,iopt_sfc=config_flags%opt_sfc, iopt_frz=config_flags%opt_frz &
- & ,iopt_inf=config_flags%opt_inf, iopt_rad=config_flags%opt_rad &
- & ,iopt_alb=config_flags%opt_alb, iopt_snf=config_flags%opt_snf &
- & ,iopt_tbot=config_flags%opt_tbot, iopt_stc=config_flags%opt_stc &
- & ,iopt_gla=config_flags%opt_gla, iopt_rsf=config_flags%opt_rsf &
- & ,iopt_soil=config_flags%opt_soil, iopt_pedo=config_flags%opt_pedo &
- & ,iopt_crop=config_flags%opt_crop, iopt_irr=config_flags%opt_irr &
- & ,iopt_irrm=config_flags%opt_irrm &
- & , isnowxy=grid%isnowxy , tvxy=grid%tvxy , tgxy=grid%tgxy &
- & ,canicexy=grid%canicexy ,canliqxy=grid%canliqxy, eahxy=grid%eahxy &
- & , tahxy=grid%tahxy , cmxy=grid%cmxy , chxy=grid%chxy &
- & , fwetxy=grid%fwetxy ,sneqvoxy=grid%sneqvoxy,alboldxy=grid%alboldxy &
- & , qsnowxy=grid%qsnowxy ,qrainxy=grid%qrainxy ,wslakexy=grid%wslakexy &
- & , zwtxy=grid%zwtxy &
- & , waxy=grid%waxy , wtxy=grid%wtxy , tsnoxy=grid%tsnoxy &
- & , zsnsoxy=grid%zsnsoxy , snicexy=grid%snicexy , snliqxy=grid%snliqxy &
- & ,lfmassxy=grid%lfmassxy ,rtmassxy=grid%rtmassxy,stmassxy=grid%stmassxy &
- & , woodxy=grid%woodxy ,stblcpxy=grid%stblcpxy,fastcpxy=grid%fastcpxy &
- & , grainxy=grid%grainxy , gddxy=grid%gddxy , pgsxy=grid%pgsxy &
- & , cropcat=grid%cropcat &
- & ,planting=grid%planting , harvest=grid%harvest ,season_gdd=grid%season_gdd &
- & , soilcomp=grid%soilcomp &
- & , soilcl1=grid%soilcl1 , soilcl2=grid%soilcl2 &
- & , soilcl3=grid%soilcl3 , soilcl4=grid%soilcl4 &
- & , xsaixy=grid%xsaixy , taussxy=grid%taussxy &
- & , t2mvxy=grid%t2mvxy , t2mbxy=grid%t2mbxy &
- & , q2mvxy=grid%q2mvxy , q2mbxy=grid%q2mbxy &
- & , tradxy=grid%tradxy , neexy=grid%neexy , gppxy=grid%gppxy &
- & , nppxy=grid%nppxy , fvegxy=grid%fvegxy , runsfxy=grid%runsfxy &
- & , runsbxy=grid%runsbxy , ecanxy=grid%ecanxy , edirxy=grid%edirxy &
- & , etranxy=grid%etranxy , fsaxy=grid%fsaxy , firaxy=grid%firaxy &
- & , aparxy=grid%aparxy , psnxy=grid%psnxy , savxy=grid%savxy &
- & , sagxy=grid%sagxy , rssunxy=grid%rssunxy , rsshaxy=grid%rsshaxy &
- & , bgapxy=grid%bgapxy , wgapxy=grid%wgapxy , tgvxy=grid%tgvxy &
- & , tgbxy=grid%tgbxy , chvxy=grid%chvxy , chbxy=grid%chbxy &
- & , shgxy=grid%shgxy , shcxy=grid%shcxy , shbxy=grid%shbxy &
- & , evgxy=grid%evgxy , evbxy=grid%evbxy , ghvxy=grid%ghvxy &
- & , ghbxy=grid%ghbxy , irgxy=grid%irgxy , ircxy=grid%ircxy &
- & , irbxy=grid%irbxy , trxy=grid%trxy , evcxy=grid%evcxy &
- & ,chleafxy=grid%chleafxy , chucxy=grid%chucxy &
- & , chv2xy=grid%chv2xy , chb2xy=grid%chb2xy , chstarxy=grid%chstarxy &
-! Noah-MP irrigation
- & , IRFRACT=grid%IRFRACT , SIFRACT=grid%SIFRACT ,MIFRACT=grid%MIFRACT &
- & , FIFRACT=grid%FIFRACT , IRNUMSI=grid%IRNUMSI ,IRNUMMI=grid%IRNUMMI &
- & , IRNUMFI=grid%IRNUMFI , IRWATSI=grid%IRWATSI ,IRWATMI=grid%IRWATMI &
- & , IRWATFI=grid%IRWATFI , IRELOSS=grid%IRELOSS ,IRSIVOL=grid%IRSIVOL &
- & , IRMIVOL=grid%IRMIVOL , IRFIVOL=grid%IRFIVOL ,IRRSPLH=grid%IRRSPLH &
- & , smoiseq=grid%smoiseq, smcwtdxy=grid%smcwtdxy, rechxy=grid%rechxy &
- & , deeprechxy=grid%deeprechxy &
- & ,gecros_state=grid%gecros_state & ! Optional gecros crop
- & ,coszen=grid%czen,xlat_urb2d=grid%hlat &
- & ,rs=rs,xlaidyn=xlaidyn &
-! mosaic tiling for Noah
- & ,sf_surface_mosaic=config_flags%sf_surface_mosaic, mosaic_cat=config_flags%mosaic_cat &
-! lake module
- & ,lakedepth2d=grid%lakedepth2d, savedtke12d=grid%savedtke12d, snowdp2d=grid%snowdp2d, h2osno2d=grid%h2osno2d &
- & ,snl2d=grid%snl2d, t_grnd2d=grid%t_grnd2d, t_lake3d=grid%t_lake3d, lake_icefrac3d=grid%lake_icefrac3d &
- & ,z_lake3d=grid%z_lake3d, dz_lake3d=grid%dz_lake3d, t_soisno3d=grid%t_soisno3d, h2osoi_ice3d=grid%h2osoi_ice3d &
- & ,h2osoi_liq3d=grid%h2osoi_liq3d, h2osoi_vol3d=grid%h2osoi_vol3d, z3d=grid%z3d, dz3d=grid%dz3d &
- & ,zi3d=grid%zi3d, watsat3d=grid%watsat3d, csol3d=grid%csol3d, tkmg3d=grid%tkmg3d &
- & ,tkdry3d=grid%tkdry3d,tksatu3d=grid%tksatu3d, LakeModel=grid%sf_lake_physics, lake_min_elev=grid%lake_min_elev &
-! end lake module
- & ,maxpatch=1,inest=1,history_interval=config_flags%history_interval & !clm
- & ,fasdas=fasdas,do_bioe=.false.,do_meganfile=.false.,num_pft_input=grid%num_pft_clm &
- & )
-!
-!-----------------------------------------------------------------------
-!
-!*** CALL FREE ATMOSPHERE TURBULENCE
-!
-!-----------------------------------------------------------------------
-!
-!$omp parallel do &
-!$omp& private(i,j,k)
- DO J=JMS,JME
- DO K=KMS,KME
- DO I=IMS,IME
- DUDT_PHY(I,K,J)=0.
- DVDT_PHY(I,K,J)=0.
- ENDDO
- ENDDO
- ENDDO
-!
-!*** THE SURFACE EXCHANGE COEFFICIENTS AKHS AND AKMS ARE ACTUALLY
-!*** MULTIPLIED BY HALF THE DEPTH OF THE LOWEST LAYER. WE MUST RETAIN
-!*** THOSE VALUES FOR THE NEXT TIMESTEP SO USE AUXILLIARY ARRAYS FOR
-!*** THE OUTPUT.
-!
-!$omp parallel do &
-!$omp& private(dzhalf,i,j)
- DO J=JTS,JTE
- DO I=ITS,ITE
- DZHALF=0.5*DZ(I,KTS,J)
- AKHS_OUT(I,J)=AKHS(I,J)*DZHALF
- AKMS_OUT(I,J)=AKMS(I,J)*DZHALF
- ENDDO
- ENDDO
-!
-!-- ETAMP_Regional logical is true for regional NAM (ETAMPNEW) or HRW (ETAMPNEW) microphysics
-!
- ETAMP_Regional=.FALSE.
- IF (CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW .OR. &
- & CONFIG_FLAGS%MP_PHYSICS==FER_MP_HIRES) ETAMP_Regional=.TRUE.
-!
- IF(ETAMP_Regional) THEN
-!-- Logical FQ_I and index PQ_I are set to values associated with snow
-! for the regional (NAM, HWRF) versions of the microphysics
- FQ_I=F_QS
- PQ_I=P_QS
- ELSE
- FQ_I=F_QI
- PQ_I=P_QI
- ENDIF
-#if HWRF==1
- CALL nl_get_var_ric(1, var_ric)
- CALL nl_get_coef_ric_s(1, coef_ric_s)
- CALL nl_get_coef_ric_l(1, coef_ric_l)
- CALL nl_get_pert_pbl(1,pert_pbl)
- CALL nl_get_ens_pblamp(1,ens_pblamp)
-! write(0,*) 'var_ric & coef_ric_s l from namelist Kwon ',var_ric,coef_ric_s,coef_ric_l
-#endif
-!
- CALL PBL_DRIVER( &
- & ITIMESTEP=NTSD,DT=DT &
- & ,U_FRAME=U_FRAME,V_FRAME=V_FRAME &
- & ,RUBLTEN=DUDT_PHY,RVBLTEN=DVDT_PHY &
- & ,RTHBLTEN=RTHBLTEN,RQVBLTEN=RQVBLTEN & !BSF
- & ,RQCBLTEN=RQCBLTEN,RQIBLTEN=RQIBLTEN & !BSF
-!BSF & ,RQRBLTEN=RQRBLTEN,RQSBLTEN=RQSBLTEN & !BSF
-!BSF & ,RQGBLTEN=RQGBLTEN & !BSF
- & ,TSK=TSFC,XLAND=XLAND,ZNT=Z0 &
-#if ( HWRF == 1 )
- & ,MSANG=MSANG,SCURX=SCURX,SCURY=SCURY &
- & ,IWAVECPL=CONFIG_FLAGS%IWAVECPL &
- & ,LCURR_SF=CONFIG_FLAGS%LCURR_SF &
-
- & ,MZNT=MZ0 &
-#endif
- & ,HPBL_HOLD=HPBL_HOLD & !for new KSAS
- & ,HT=SFCZ & !KWON
- & ,UST=USTAR,MIXHT=MIXHT,PBLH=PBLH &
- & ,HFX=TWBS,QFX=QWBS,GRDFLX=GRNFLX &
- & ,U_PHY=U_PHY,V_PHY=V_PHY,TH_PHY=TH_PHY,RHO=RR &
- & ,P_PHY=P_PHY,PI_PHY=PI_PHY,P8W=P8W,T_PHY=T_PHY &
- & ,DZ8W=DZ,Z=Z,TKE_PBL=TKE,EL_PBL=EL_MYJ,F=F &
- & ,EXCH_H=EXCH_H,EXCH_M=EXCH_M,AKHS=AKHS,AKMS=AKMS &
- & ,FM=FM,FHH=FH &
- & ,YSU_TOPDOWN_PBLMIX=CONFIG_FLAGS%YSU_TOPDOWN_PBLMIX &
- & ,SHINHONG_TKE_DIAG=CONFIG_FLAGS%SHINHONG_TKE_DIAG &
- & ,THZ0=THZ0,QZ0=QZ0,UZ0=UZ0H,VZ0=VZ0H &
- & ,QSFC=QS,LOWLYR=LOWLYR &
- & ,PSIM=PSIM,PSIH=PSIH,GZ1OZ0=GZ1OZ0 &
- & ,U10=U10,V10=V10,UOCE=UOCE,VOCE=VOCE,T2=T2,WSPD=WSPD,BR=BR,CHKLOWQ=CHKLOWQ &
- & ,DX=DX,DY=DY,STEPBL=NPHS,WARM_RAIN=WARM_RAIN &
- & ,KPBL=KPBL,CT=CT,LH=ELFLX,SNOW=SNOW,XICE=SICE &
- & ,BL_PBL_PHYSICS=config_flags%bl_pbl_physics &
- & ,RA_LW_PHYSICS=config_flags%ra_lw_physics &
- & ,MFSHCONV=config_flags%mfshconv & ! work with QNSE PBL
- & ,rc_mf=rc_mf & ! QNSE
- & ,IDS=IDS,IDE=IDE,JDS=JDS,JDE=JDE,KDS=KDS,KDE=KDE &
- & ,IMS=IMS,IME=IME,JMS=JMS,JME=JME,KMS=KMS,KME=KME &
- & ,I_START=GRID%I_START,I_END=GRID%I_END &
- & ,J_START=GRID%J_START,J_END=GRID%J_END &
- & ,KTS=KTS,KTE=KTE,NUM_TILES=GRID%NUM_TILES &
- & ,CTOPO=grid%ctopo,CTOPO2=grid%ctopo2 &
- & ,WINDFARM_OPT=config_flags%windfarm_opt &
- & ,POWER=grid%POWER &
- & ,NUM_SCALAR=1, NUM_TRACER=1 & ! parameters not used by NMM
-#if (NMM_CORE==1)
- & ,DISHEAT=DISHEAT &
-#endif
- ! Optional args
- & ,RTHRATEN=RTHRATEN &
-#if (HWRF==1)
- & ,GFS_ALPHA=GRID%GFS_ALPHA &
-#endif
- & ,HPBL2D=HPBL2D, EVAP2D=EVAP2D, HEAT2D=HEAT2D & !Kwon S&P
- & ,RC2D=RC2D & !KWON
-#if HWRF==1
- & ,VAR_RIC=VAR_RIC & !Kwon Ric
-#endif
- & ,DKU3D=DKU3D,DKT3D=DKT3D
-#if HWRF==1
- & ,coef_ric_l=coef_ric_l,coef_ric_s=coef_ric_s & !Kwon for Ric
- & ,pert_pbl=pert_pbl &
- & ,ens_random_seed=ens_random_seed &
- & ,ens_pblamp=ens_pblamp &
-#endif
- & ,QV_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QV),F_QV=F_QV &
- & ,QC_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QC),F_QC=F_QC &
- & ,QI_CURR=MOIST_TRANS(IMS,KMS,JMS,PQ_I),F_QI=FQ_I &
- & ,QR_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QR),F_QR=F_QR &
- & ,QS_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QS),F_QS=F_QS &
- & ,QG_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QG),F_QG=F_QG &
- & ,HOL=HOL,sf_sfclay_physics=CONFIG_FLAGS%SF_SFCLAY_PHYSICS &
- & ,IS_CAMMGMP_USED=IS_CAMMGMP_USED &
- & ,wstar=wstar_ysu,delta=delta_ysu &
- & ,fasdas=fasdas &
- & ,sf_urban_physics=CONFIG_FLAGS%SF_URBAN_PHYSICS)
-!
-!output PBL tendency
-!
-!$omp parallel do &
-!$omp& private(i,j,k)
- DO J=JMS,JME
- DO K=KMS,KME
- DO I=IMS,IME
- DUBLDT(I,J,K)=DUDT_PHY(I,K,J)
- DVBLDT(I,J,K)=DVDT_PHY(I,K,J)
- DTHBLDT(I,J,K)=RTHBLTEN(I,K,J)
- DQVBLDT(I,J,K)=RQVBLTEN(I,K,J)
- ENDDO
- ENDDO
- ENDDO
-!
-
-!*** NOTE THAT THE EXCHANGE COEFFICIENTS FOR HEAT EXCH_H COMING OUT OF
-!*** PBL_DRIVER ARE DEFINED AT THE TOPS OF THE LAYERS KTS TO KTE-1
-!*** IF MODULE_BL_MYJPBL WAS INVOKED.
-!
-!-----------------------------------------------------------------------
-! UNCOMPUTED LOCATIONS MUST BE FILLED IN FOR THE POST-PROCESSOR
-!-----------------------------------------------------------------------
-!
-!*** EASTERN GLOBAL BOUNDARY
-!
- IF(MYIE==IDE)THEN
-!$omp parallel do &
-!$omp& private(i,j)
- DO J=JDS,JDE
- IF (J>=MYJS.AND.J<=MYJE)THEN
- TH10(MYIE,J)=TH10(MYIE-1,J)
- Q10(MYIE,J)=Q10(MYIE-1,J)
- U10(MYIE,J)=U10(MYIE-1,J)
- V10(MYIE,J)=V10(MYIE-1,J)
- TSHLTR(MYIE,J)=TSHLTR(MYIE-1,J)
- QSHLTR(MYIE,J)=QSHLTR(MYIE-1,J)
- ENDIF
- ENDDO
- ENDIF
-!
-!*** SOUTHERN GLOBAL BOUNDARY
-!
-
- IF(MYJS==JDS)THEN
- DO J=JDS,JDS+1
- DO I=IDS,IDE
- IF (I>=MYIS.AND.I<=MYIE) THEN
- TH10(I,J)=TH10(I,MYJS+2)
- Q10(I,J)=Q10(I,MYJS+2)
- U10(I,J)=U10(I,MYJS+2)
- V10(I,J)=V10(I,MYJS+2)
- TSHLTR(I,J)=TSHLTR(I,MYJS+2)
- QSHLTR(I,J)=QSHLTR(I,MYJS+2)
- ENDIF
- ENDDO
- ENDDO
- ENDIF
-!
-!*** NORTHERN GLOBAL BOUNDARY
-!
- IF(MYJE==JDE)THEN
-!$omp parallel do &
-!$omp& private(i,j)
- DO J=MYJE-1,MYJE
- DO I=IDS,IDE
- IF (I>=MYIS.AND.I<=MYIE) THEN
- TH10(I,J)=TH10(I,MYJE-2)
- Q10(I,J)=Q10(I,MYJE-2)
- U10(I,J)=U10(I,MYJE-2)
- V10(I,J)=V10(I,MYJE-2)
- TSHLTR(I,J)=TSHLTR(I,MYJE-2)
- QSHLTR(I,J)=QSHLTR(I,MYJE-2)
- ENDIF
- ENDDO
- ENDDO
- ENDIF
-!
-#if ( HWRF == 1 )
- if(size(grid%windsq_swath)>1) then
- do j=max(jts,jds),min(jte,jde-1)
- do i=max(its,ids),min(ite,ide-1)
- if(grid%interesting(i,j)==0) cycle
- wind=u10(i,j)**2 + v10(i,j)**2
- if(wind>grid%windsq_swath(i,j)) grid%windsq_swath(i,j)=wind
- enddo
- enddo
- endif
-#endif
-
- IF(CONFIG_FLAGS%SF_SFCLAY_PHYSICS==1)THEN ! non-NMM package
-!$omp parallel do &
-!$omp& private(i,j)
- DO J=MYJS1,MYJE1
- DO I=MYIS,MYIE1
-! TSHLTR(I,J)=TSHLTR(I,J)*(1.E5/PSHLTR(I,J))**RCP
- IF(TSHLTR(I,J)<200..OR.TSHLTR(I,J)>350.)THEN
- WRITE(message,*)'Troublesome TSHLTR...I,J,TSHLTR,PSHLTR: ' &
- ,I,J,TSHLTR(I,J),PSHLTR(I,J)
- CALL wrf_message(trim(message))
- ENDIF
- ENDDO
- ENDDO
- ENDIF
-!
-!-----------------------------------------------------------------------
-!*** COMPUTE MODEL LAYER CONTAINING THE TOP OF THE BOUNDARY LAYER
-!-----------------------------------------------------------------------
-!
- IF(CONFIG_FLAGS%BL_PBL_PHYSICS/=MYJPBLSCHEME)THEN
- LENGTH_ROW=MYIE1-MYIS1+1
- DO J=MYJS2,MYJE2
- DO I=MYIS1,MYIE1
- KPBL(I,J)=-1000
- ENDDO
- ENDDO
-!
-!$omp parallel do &
-!$omp& private(altitude,i,j,k,kount_all)
- DO J=MYJS2,MYJE2
- KOUNT_ALL=0
- find_kpbl : DO K=KTS,KTE
- DO I=MYIS1,MYIE1
- ALTITUDE=Z(I,K+1,J)-SFCZ(I,J)
- IF(PBLH(I,J)<=ALTITUDE.AND.KPBL(I,J)<0)THEN
- KPBL(I,J)=K
- KOUNT_ALL=KOUNT_ALL+1
- ENDIF
- IF(KOUNT_ALL==LENGTH_ROW)EXIT find_kpbl
- ENDDO
- ENDDO find_kpbl
- ENDDO
- ENDIF
-!
- IF(MODEL_CONFIG_REC%SF_SURFACE_PHYSICS(GRID%ID)==99)THEN
- SNO_FACTR=1.
- ELSE
- SNO_FACTR=1000.
- ENDIF
-!
-!$omp parallel do &
-!$omp& private(i,j)
- DO J=MYJS2,MYJE2
- DO I=MYIS1,MYIE1
- SNO(I,J)=SNOW(I,J)
- SI(I,J)=SNOWH(I,J)*SNO_FACTR
- LPBL(I,J)=KTE-KPBL(I,J)+1
- ENDDO
- ENDDO
-!
-!-----------------------------------------------------------------------
-!*** DIAGNOSTIC RADIATION ACCUMULATION
-!-----------------------------------------------------------------------
-!
-!$omp parallel do &
-!$omp& private(i,j,tsfc2)
- DO J=MYJS2,MYJE2
- DO I=MYIS,MYIE
- ASWIN (I,J)=ASWIN (I,J)+RSWIN(I,J)*HBM2(I,J)*FACTRS(I,J)
- ASWOUT(I,J)=ASWOUT(I,J)-RSWOUT(I,J)*HBM2(I,J)*FACTRS(I,J)
- ASWTOA(I,J)=ASWTOA(I,J)+RSWTOA(I,J)*HBM2(I,J)*FACTRS(I,J)
- ALWIN (I,J)=ALWIN (I,J)+RLW_DN_SFC(I,J)
- ALWOUT(I,J)=ALWOUT(I,J)-RADOT (I,J)*HBM2(I,J)
- ALWTOA(I,J)=ALWTOA(I,J)+RLWTOA(I,J)*HBM2(I,J)
-!
- TSFC2=TSFC(I,J)*TSFC(I,J)
- RADOT(I,J)=HBM2(I,J)*EPSR(I,J)*STBOLT*TSFC2*TSFC2
- THS(I,J)=TSFC(I,J)*EXNSFC(I,J)
- PREC(I,J)=0.
- ENDDO
- ENDDO
-!
-!=======================================================================
-!=== Begin gravity wave drag (GWD) and mountain blocking (MB) ========
-!=======================================================================
-!
- IGS=MYIS1
- IGE=MYIE1
- JGS=MYJS2
- JGE=MYJE2
-!dbg !dbg
-!dbg kpblmin=100
-!dbg kpblmax=-100
-!dbg DO J=JGS,JGE
-!dbg DO I=IGS,IGE
-!dbg kpblmin=min(kpblmin,kpbl(i,j))
-!dbg kpblmax=max(kpblmax,kpbl(i,j))
-!dbg enddo
-!dbg enddo
-!dbg print *,'TURBL: IGS,IGE,JGS,JGE,kpblmin,kpblmax=',IGS,IGE,JGS,JGE,kpblmin,kpblmax
-!dbg
-
-! print *,'grid%id gwd_opt at module_PHYSICS ',grid%id, grid%gwd_opt
-! WRITE(0,*)'grid%id gwd_opt at module_PHYSICS ',grid%id, grid%gwd_opt
-! WRITE(MESSAGE,125)grid%gwd_opt
-!125 FORMAT(1X,'grid%id module_PHYSICS.F : gwd_opt ',I2,2X,I2)
-
-
-#if ( HWRF == 1 )
- IF (grid%gwd_opt .eq. 2 .AND. grid%id.eq.1) THEN !Kwon's doing for parent only now
-#else
- IF (grid%gwd_opt .eq. 2) THEN
-#endif
-! print *,'==grid%id gwd_opt at module_PHYSICS inside gwd ',grid%id, grid%gwd_opt !because there is no data for nest domain
-
- CALL wrf_message("GWD usage currently may be problematic for some cases - use at own risk")
-
- CALL GWD_driver(U=U_PHY,V=V_PHY,T=T_PHY &
- & ,Q=MOIST_TRANS(IMS,KMS,JMS,P_QV) &
- & ,Z=Z,DP=DELP,PINT=P8W,PMID=P_PHY,EXNR=PI_PHY &
- & ,KPBL=KPBL,ITIME=NTSD &
- & ,HSTDV=HSTDV,HCNVX=HCNVX,HASYW=HASYW,HASYS=HASYS &
- & ,HASYSW=HASYSW,HASYNW=HASYNW,HLENW=HLENW &
- & ,HLENS=HLENS,HLENSW=HLENSW,HLENNW=HLENNW &
- & ,HANGL=HANGL,HANIS=HANIS,HSLOP=HSLOP,HZMAX=HZMAX &
- & ,CROT=CROT,SROT=SROT &
- & ,DUDT=DUDT_GWD,DVDT=DVDT_GWD &
- & ,UGWDsfc=UGWDsfc,VGWDsfc=VGWDsfc,XLAND=XLAND & !ADDED BY KWON FOR OCEAN
- & ,IDS=IDS,IDE=IDE,JDS=JDS,JDE=JDE,KDS=KDS,KDE=KDE &
- & ,IMS=IMS,IME=IME,JMS=JMS,JME=JME,KMS=KMS,KME=KME &
- & ,ITS=IGS,ITE=IGE,JTS=JGS,JTE=JGE,KTS=KTS,KTE=KTE )
-
-!=======================================================================
-!===== End gravity wave drag (GWD) and mountain blocking (MB) ========
-!=======================================================================
-!
-!-----------------------------------------------------------------------
-!*** TRANSFER THE WIND TENDENCIES.
-!-----------------------------------------------------------------------
-!
- DO K=KTS,KTE
- DO J=JTS,JTE
- DO I=ITS,ITE
-
-
-!mp temporary bandaid limiting GWD/MB wind tendencies
-
- IF (DUDT_GWD(I,K,J) .gt. 1.6) then
- write(message,*) 'BIG DUDT_GWD:: ', I,K,J, DUDT_GWD(I,K,J)
- CALL wrf_message(message)
- DUDT_GWD(I,K,J)=1.6
- ENDIF
-
- IF (DUDT_GWD(I,K,J) .lt. -1.6) then
- write(message,*) 'BIG DUDT_GWD:: ', I,K,J, DUDT_GWD(I,K,J)
- CALL wrf_message(message)
- DUDT_GWD(I,K,J)=-1.6
- ENDIF
-
- IF (DVDT_GWD(I,K,J) .gt. 1.6) then
- write(message,*) 'BIG DVDT_GWD:: ', I,K,J, DVDT_GWD(I,K,J)
- CALL wrf_message(message)
- DVDT_GWD(I,K,J)=1.6
- ENDIF
-
- IF (DVDT_GWD(I,K,J) .lt. -1.6) then
- write(message,*) 'BIG DVDT_GWD:: ', I,K,J, DVDT_GWD(I,K,J)
- CALL wrf_message(message)
- DVDT_GWD(I,K,J)=-1.6
- ENDIF
-
-!mp end temporary bandaid
-
- DUDT(I,J,K)=DUDT_PHY(I,K,J)+DUDT_GWD(I,K,J)
- DVDT(I,J,K)=DVDT_PHY(I,K,J)+DVDT_GWD(I,K,J)
-
- ENDDO
- ENDDO
- ENDDO
-
- ELSE ! no GWD
-
- DO K=KTS,KTE
- DO J=JTS,JTE
- DO I=ITS,ITE
- DUDT(I,J,K)=DUDT_PHY(I,K,J)
- DVDT(I,J,K)=DVDT_PHY(I,K,J)
- ENDDO
- ENDDO
- ENDDO
-
- ENDIF ! gwd_opt
-!
-!-----------------------------------------------------------------------
-!*** TRANSPOSE THE MOIST_TRANS ARRAY BACK TO THE PROGNOSTIC MOIST ARRAY.
-!-----------------------------------------------------------------------
-!
- DO N=1,N_MOIST
-!$omp parallel do &
-!$omp& private(i,j,k)
- DO J=JMS,JME
- DO K=KMS,KME
- DO I=IMS,IME
- MOIST(I,J,K,N)=MOIST_TRANS(I,K,J,N)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-!
- DEALLOCATE(MOIST_TRANS,STAT=ISTAT)
-!
-!-----------------------------------------------------------------------
-!*** UPDATE TEMPERATURE, SPECIFIC HUMIDITY, CLOUD, AND TKE.
-!-----------------------------------------------------------------------
-!
- E_BDY=(ITE>=IDE)
-!
- ETAMP_PHYSICS=ETAMP_Regional
- IF (CONFIG_FLAGS%MP_PHYSICS==ETAMP_HWRF) ETAMP_PHYSICS=.TRUE.
-!
-!$omp parallel do &
-!$omp& private(dqdt,dtdt,i,iend,j,k,qi,qold,qr,qw,ratiomx,i_m)
- DO K=KTS,KTE
- DO J=MYJS2,MYJE2
- IEND=MYIE1
- IF(E_BDY.AND.MOD(J,2)==0)IEND=IEND-1
-!
- DO I=MYIS1,IEND
- DTDT=RTHBLTEN(I,K,J)*PI_PHY(I,K,J)
- DQDT=RQVBLTEN(I,K,J) !Mixing ratio tendency
- T(I,J,K)=T(I,J,K)+DTDT*DTPHS
- QOLD=Q(I,J,K)
- RATIOMX=QOLD/(1.-QOLD)+DQDT*DTPHS
- Q(I,J,K)=RATIOMX/(1.+RATIOMX)
-! Q(I,J,K)=MAX(Q(I,J,K),EPSQ)
- MOIST(I,J,K,P_QV)=MAX(EPSQ,(MOIST(I,J,K,P_QV)+RQVBLTEN(I,K,J)*DTPHS) )
- CWM(I,J,K)=0.
-!
- pbl_check1: IF(config_flags%mp_physics==fer_mp_hires_advect) then
- ! Update QI and QRIMEF:
- call QITEND_FER_HIRES_ADVECT( &
- MOIST(I,J,K,P_QI), &
- SCALAR(I,J,K,P_QRIMEF), &
- RQIBLTEN(I,K,J)*DTPHS)
-
- ! Update QC:
- MOIST(I,J,K,P_QC)=MAX(EPSQ,(MOIST(I,J,K,P_QC)+RQCBLTEN(I,K,J)*DTPHS))
- ELSEIF (.NOT.ETAMP_PHYSICS) THEN
-
- DO I_M=1,N_MOIST
- IF(I_M==P_QC) THEN
- MOIST(I,J,K,I_M)=MAX(EPSQ,(MOIST(I,J,K,I_M)+RQCBLTEN(I,K,J)*DTPHS) )
- ELSE IF(I_M==P_QI) THEN
- MOIST(I,J,K,I_M)=MAX(EPSQ,(MOIST(I,J,K,I_M)+RQIBLTEN(I,K,J)*DTPHS) )
- ENDIF
- IF(I_M/=P_QV) CWM(I,J,K)=CWM(I,J,K)+MOIST(I,J,K,I_M)
- ENDDO
- ELSE pbl_check1
-!
-!-- Allow vertical mixing to modify cloud ice + snow for ETAMPNEW
-!
- QW=MAX(0.,MOIST(I,J,K,P_QC)+RQCBLTEN(I,K,J)*DTPHS )
- pbl_check2: IF (ETAMP_Regional) THEN
- QI=MAX(0.,MOIST(I,J,K,P_QS)+RQIBLTEN(I,K,J)*DTPHS ) !-- Total ice
-!BSF QR=MAX(0.,MOIST(I,J,K,P_QR)+RQRBLTEN(I,K,J)*DTPHS )
- QR=MAX(0.,MOIST(I,J,K,P_QR) )
- MOIST(I,J,K,P_QC)=QW
- MOIST(I,J,K,P_QS)=QI
- MOIST(I,J,K,P_QR)=QR
- ELSE IF (CONFIG_FLAGS%MP_PHYSICS==ETAMP_HWRF) THEN !-- pbl_check2
- QI=MAX(0.,MOIST(I,J,K,P_QI)+RQIBLTEN(I,K,J)*DTPHS ) !-- Total ice
-!BSF QR=MAX(0.,MOIST(I,J,K,P_QR)+RQRBLTEN(I,K,J)*DTPHS )
- QR=MAX(0.,MOIST(I,J,K,P_QR) )
- MOIST(I,J,K,P_QC)=QW
- MOIST(I,J,K,P_QI)=QI
- MOIST(I,J,K,P_QR)=QR
- ENDIF pbl_check2
- CWM(I,J,K)=QW+QI+QR
-!
- IF(QI<=EPSQ)THEN
- F_ICE(I,K,J)=0.
- ELSE
- F_ICE(I,K,J)=MAX(0.,MIN(1.,QI/CWM(I,J,K)))
- ENDIF
-!
- IF(QR<=EPSQ)THEN
- F_RAIN(I,K,J)=0.
- ELSE
- F_RAIN(I,K,J)=QR/(QW+QR)
- ENDIF
-!
- ENDIF pbl_check1
-!
- Q2(I,J,K)=2.*TKE(I,K,J)
- ENDDO
- ENDDO
-!
- ENDDO
-!
-!-----------------------------------------------------------------------
-!***
-!*** SAVE SURFACE-RELATED FIELDS.
-!***
-!-----------------------------------------------------------------------
-!$omp parallel do &
-!$omp& private(i,j,llij,xlvrw)
- DO J=MYJS2,MYJE2
- DO I=MYIS1,MYIE1
- LLIJ=LOWLYR(I,J)
-!
-!-----------------------------------------------------------------------
-!*** INSTANTANEOUS SENSIBLE AND LATENT HEAT FLUX
-!-----------------------------------------------------------------------
-!
- TWBS(I,J)=-TWBS(I,J)
- QWBS(I,J)=-QWBS(I,J)*XLV*CHKLOWQ(I,J)
-!
-!-----------------------------------------------------------------------
-!*** ACCUMULATED QUANTITIES.
-!*** IN OPNL LSM, SFCEVP APPEARS TO BE IN UNITS OF
-!*** METERS OF LIQUID WATER. IT IS COMING FROM
-!*** WRF MODULE AS KG/M**2.
-!-----------------------------------------------------------------------
-!
- SFCSHX(I,J)=SFCSHX(I,J)+TWBS(I,J)
- SFCLHX(I,J)=SFCLHX(I,J)+QWBS(I,J)
- XLVRW=DTPHS/(XLV*RHOWATER)
- SFCEVP(I,J)=SFCEVP(I,J)-QWBS(I,J)*XLVRW
- POTEVP(I,J)=POTEVP(I,J)-QWBS(I,J)*SM(I,J)*XLVRW
- POTFLX(I,J)=POTEVP(I,J)*FACTOR
- SUBSHX(I,J)=SUBSHX(I,J)+GRNFLX(I,J)
- ENDDO
- ENDDO
-!
-!-----------------------------------------------------------------------
-!*** COUNTERS
-!-----------------------------------------------------------------------
-!
- APHTIM=APHTIM+1.
- ARDSW =ARDSW +1.
- ARDLW =ARDLW +1.
- ASRFC =ASRFC +1.
-!-----------------------------------------------------------------------
-!
- END SUBROUTINE TURBL
-!
-!-----------------------------------------------------------------------
-!***********************************************************************
- SUBROUTINE UV_H_TO_V(NTSD,DT,NPHS,UZ0H,VZ0H,UZ0,VZ0 &
- & ,DUDT,DVDT,U,V,HBM2,IVE,IVW &
- & ,IDS,IDE,JDS,JDE,KDS,KDE &
- & ,IMS,IME,JMS,JME,KMS,KME &
- & ,ITS,ITE,JTS,JTE,KTS,KTE)
-!***********************************************************************
-!$$$ SUBPROGRAM DOCUMENTATION BLOCK
-! . . .
-! SUBPROGRAM: UV_H_TO_V INTERPOLATE WINDS FROM H TO V POINTS
-! PRGRMMR: BLACK ORG: W/NP22 DATE: 05-02-22
-!
-! ABSTRACT:
-! INTERPOLATE WINDS BACK TO V POINTS AFTER TURBULENCE
-!
-! PROGRAM HISTORY LOG :
-! 05-02-22 BLACK - ORIGINATOR
-! 05-12-12 BLACK - CONVERTED FROM IKJ TO IJK
-!
-! USAGE: CALL TURBL FROM SOLVE_NMM
-!
-! ATTRIBUTES:
-! LANGUAGE: FORTRAN 90
-! MACHINE : IBM
-!$$$
-!-----------------------------------------------------------------------
-!
- IMPLICIT NONE
-!
-!-----------------------------------------------------------------------
-!
- INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
- & ,IMS,IME,JMS,JME,KMS,KME &
- & ,ITS,ITE,JTS,JTE,KTS,KTE &
- & ,NPHS,NTSD
-!
- INTEGER, DIMENSION(JMS:JME),INTENT(IN) :: IVE,IVW
-!
- REAL,INTENT(IN) :: DT
-!
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: HBM2,UZ0H,VZ0H
-!
- REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: DUDT,DVDT
-!
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: UZ0,VZ0
-!
- REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: U,V
-!
-!-----------------------------------------------------------------------
-!***
-!*** LOCAL VARIABLES
-!***
-!-----------------------------------------------------------------------
-!
- INTEGER :: I,IEND,J,K
-!
- REAL :: DTPHS
-!
- LOGICAL :: E_BDY
-!
-!-----------------------------------------------------------------------
-!-----------------------------------------------------------------------
-!
- DTPHS=NPHS*DT
- E_BDY=(ITE>=IDE)
-!
-!-----------------------------------------------------------------------
-!*** RECONSTRUCT UZ0 AND VZ0 ON VELOCITY POINTS.
-!-----------------------------------------------------------------------
-!
-!$omp parallel do &
-!$omp& private(i,j)
- DO J=MYJS2,MYJE2
- DO I=MYIS,MYIE
- UZ0(I,J)=(UZ0H(I+IVE(J),J)*HBM2(I+IVE(J),J) &
- & +UZ0H(I+IVW(J),J)*HBM2(I+IVW(J),J) &
- & +UZ0H(I,J+1)*HBM2(I,J+1)+UZ0H(I,J-1)*HBM2(I,J-1))*0.25
- VZ0(I,J)=(VZ0H(I+IVE(J),J)*HBM2(I+IVE(J),J) &
- & +VZ0H(I+IVW(J),J)*HBM2(I+IVW(J),J) &
- & +VZ0H(I,J+1)*HBM2(I,J+1)+VZ0H(I,J-1)*HBM2(I,J-1))*0.25
- ENDDO
- ENDDO
-!
-!-----------------------------------------------------------------------
-!*** INTERPOLATE WIND TENDENCIES TO VELOCITY POINTS AND UPDATE WINDS.
-!-----------------------------------------------------------------------
-!
-!$omp parallel do &
-!$omp& private(i,iend,j,k)
- DO K=KTS,KTE
- DO J=MYJS2,MYJE2
- IEND=MYIE1
- IF(E_BDY.AND.MOD(J,2)==1)IEND=IEND-1
-!
- DO I=MYIS1,IEND
- U(I,J,K)=(DUDT(I+IVE(J),J,K)+DUDT(I+IVW(J),J,K) &
- & +DUDT(I,J+1,K)+DUDT(I,J-1,K))*0.25*DTPHS &
- & +U(I,J,K)
- V(I,J,K)=(DVDT(I+IVE(J),J,K)+DVDT(I+IVW(J),J,K) &
- & +DVDT(I,J+1,K)+DVDT(I,J-1,K))*0.25*DTPHS &
- & +V(I,J,K)
- ENDDO
- ENDDO
- ENDDO
-!-----------------------------------------------------------------------
-!
- END SUBROUTINE UV_H_TO_V
-!
-!-----------------------------------------------------------------------
-!***********************************************************************
-!-----------------------------------------------------------------------
- SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL &
- & ,GPS,RESTRT,HYDRO &
- & ,CLDEFI,N_MOIST,N_SCALAR,ENSDIM &
- & ,MOIST,SCALAR &
- & ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2 &
- & ,F_ICE,F_RAIN &
-!*** Changes for other cu-schemes, most for gd scheme
- & ,APR_GR,APR_W,APR_MC,TTEN,QTEN &
- & ,APR_ST,APR_AS,APR_CAPMA &
- & ,APR_CAPME ,APR_CAPMI &
- & ,MASS_FLUX ,XF_ENS &
- & ,PR_ENS,GSW &
- & ,GD_CLOUD,GD_CLOUD2,KTOP_DEEP &
- & ,PDTOP,PT,PD,RES,PINT,T,Q,CWM,TCUCN &
- & ,OMGALF,U,V,W,Z,FIS,W0AVG &
- & ,PREC,ACPREC,CUPREC,CUPPT,CPRATE &
- & ,SM,HBM2,PBLH,LPBL,CNVBOT,CNVTOP &
- & ,HTOP,HBOT,HTOPD,HBOTD,HTOPS,HBOTS &
- & ,RTHBLTEN,RQVBLTEN,RTHRATEN &
-#if (NMM_CORE==1)
- & ,TWBS,QWBS &
- & ,DUCUDT, DVCUDT, MOMMIX, store_rand &
- & ,DTHCUDT,DQVCUDT,DQRCUDT,DQCCUDT,DQICUDT &! added output CU tendency
- & ,DQSCUDT &! added output CU tendency
-
-#endif
- & ,HPBL2D,EVAP2D,HEAT2D & !Kwon S&P
- & ,DX2D,DYNMM & ! Scale-aware sas
- & ,SCALEFUN, SCALEFUN1 & !scale functions
- & ,SIGMU, SIGMU1 & !updraft fraction
- & ,AVCNVC,ACUTIM,IHE,IHW &
- & ,GRID,CONFIG_FLAGS &
- & ,HPBL_HOLD & ! for new KSAS
- & ,IDS,IDE,JDS,JDE,KDS,KDE &
- & ,IMS,IME,JMS,JME,KMS,KME &
- & ,IPS,IPE,JPS,JPE,KPS,KPE &
- & ,ITS,ITE,JTS,JTE,KTS,KTE)
-!***********************************************************************
-!$$$ SUBPROGRAM DOCUMENTATION BLOCK
-! . . .
-! SUBPROGRAM: CUCNVC CONVECTIVE PRECIPITATION OUTER DRIVER
-! PRGRMMR: BLACK ORG: W/NP22 DATE: 02-03-21
-!
-! ABSTRACT:
-! CUCVNC DRIVES THE WRF CONVECTION SCHEMES
-!
-! PROGRAM HISTORY LOG:
-! 02-03-21 BLACK - ORIGINATOR
-! 04-11-18 BLACK - THREADED
-! 05-12-15 BLACK - CONVERTED FROM IKJ TO IJK
-!
-! USAGE: CALL CUCNVC FROM SOLVE_NMM
-!
-! ATTRIBUTES:
-! LANGUAGE: FORTRAN 90
-! MACHINE : IBM
-!$$$
-!-----------------------------------------------------------------------
-!
- IMPLICIT NONE
-!
-!-----------------------------------------------------------------------
-!
- INTEGER,INTENT(IN) :: ENSDIM &
- & ,IDS,IDE,JDS,JDE,KDS,KDE &
- & ,IMS,IME,JMS,JME,KMS,KME &
- & ,IPS,IPE,JPS,JPE,KPS,KPE &
- & ,ITS,ITE,JTS,JTE,KTS,KTE &
- & ,N_MOIST,NCNVC,NTSD,NRADS,NRADL,N_SCALAR
-!
- INTEGER, DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW
-!
- INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LPBL
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX2D ! scale-sware sas
- REAL,INTENT(IN) :: DYNMM ! Delt_Y
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: SCALEFUN,SCALEFUN1 ! scale-sware sas
- ! scale functions
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: SIGMU,SIGMU1 ! updraft fractional area
-
-!
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: HPBL2D,EVAP2D,HEAT2D !Kwon S&P
-
- REAL,DIMENSION(IMS:IME,JMS:JME) :: SHALL
-!
- REAL,INTENT(IN) :: DT,GPS,PDTOP,PT
-!
- REAL,INTENT(INOUT) :: ACUTIM,AVCNVC
-!
- REAL,DIMENSION(KMS:KME-1),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
- REAL,DIMENSION(KMS:KME ),INTENT(IN) :: ETA1,ETA2
-!
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: FIS,HBM2,PD,RES,SM
-!
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ACPREC,CLDEFI &
- & ,CNVBOT,CNVTOP &
- & ,CUPPT,CUPREC &
- & ,HBOT,HTOP &
- & ,HBOTD,HTOPD &
- & ,HBOTS,HTOPS &
- & ,PREC,CPRATE &
- & ,APR_GR,APR_W,APR_MC &
- & ,APR_ST,APR_AS,APR_CAPMA &
- & ,APR_CAPME,APR_CAPMI &
- & ,GSW,MASS_FLUX
-#if (NMM_CORE==1)
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: store_rand
-#endif
-!Biswas
- REAL,DIMENSION(IMS:IME,JMS:JME) :: HFX,QFX,PBLH
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: TWBS,QWBS
- REAL,DIMENSION(KMS:KME) :: ZNU
- REAL, DIMENSION(IMS:IME, KMS:KME, JMS:JME) :: &
- RUCUTEN, &
- RVCUTEN,RQVFTEN
-
- REAL,DIMENSION(IMS:IME,JMS:JME) :: HPBL_HOLD
-!
- REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: F_ICE &
- & ,F_RAIN
-!
- REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: QTEN &
- & ,RQVBLTEN &
- & ,RTHBLTEN &
- & ,RTHRATEN &
- & ,TTEN
-!
-#if (NMM_CORE==1)
- REAL, INTENT(INOUT)::MOMMIX
- REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT):: DUCUDT, DVCUDT
-! 2015-12-14 added output tendency from CU
- REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT):: DTHCUDT &
- & , DQVCUDT &
- & , DQRCUDT &
- & , DQCCUDT &
- & , DQICUDT &
- & , DQSCUDT
-!
- REAL,DIMENSION(IDS:IDE,JDS:JDE) :: DATA1
- LOGICAL, EXTERNAL::wrf_dm_on_monitor
-#endif
- REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: CWM &
- & ,OMGALF &
- & ,Q,T &
- & ,TCUCN &
- & ,U,V &
- & ,W,Z
-!
- REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: PINT
-!
- REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: W0AVG
-!
- REAL,DIMENSION(IMS:IME,JMS:JME,1:ENSDIM),INTENT(INOUT) :: PR_ENS &
- & ,XF_ENS
-!
- REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,N_MOIST) &
- & ,INTENT(INOUT) :: MOIST
-!
- REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,N_SCALAR) &
- & ,INTENT(INOUT) :: SCALAR
-!
-
- REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: GD_CLOUD &
- & ,GD_CLOUD2
- INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: KTOP_DEEP
-!
- LOGICAL,INTENT(IN) :: HYDRO,RESTRT
- LOGICAL :: IS_CAMMGMP_USED=.FALSE.
-!
- TYPE(DOMAIN),TARGET :: GRID
-!
- TYPE(GRID_CONFIG_REC_TYPE),INTENT(IN) :: CONFIG_FLAGS
-!
-!-----------------------------------------------------------------------
-!*** LOCAL VARIABLES
-!-----------------------------------------------------------------------
-!
- INTEGER :: I,ICLDCK,IENDX,ISTAT,J,K,MNTO,N,N_TIMSTPS_OUTPUT &
- & ,NCUBOT,NCUTOP,NSTEP_CNV
-!
- INTEGER,DIMENSION(IMS:IME,JMS:JME) :: KPBL,LBOT,LOWLYR,LTOP
-!
- REAL :: CAPA,CF_HI,DPL,DQDT,DTCNVC,DTDT,FICE,FRAIN,G_INV &
- & ,PCPCOL,PLYR,QI,QL_K,QR,QW,RDTCNVC,TL_K,WC,WMID,PLYRB
-
-!
- REAL,DIMENSION(KMS:KME-1) :: QL,TL
-!
- REAL,DIMENSION(IMS:IME,JMS:JME) :: CUBOT,CUTOP,NCA,PDSL &
- & ,RAINC,SFCZ,XLAND
- REAL,DIMENSION(IMS:IME,JMS:JME) :: RAINCV
-!
- REAL,DIMENSION(ITS:ITE,JTS:JTE) :: WMID_L
-!
- REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: DZ,P8W,P_PHY,PI_PHY &
- & ,RQCCUTEN,RQRCUTEN &
- & ,RQICUTEN,RQSCUTEN &
- & ,RQVCUTEN,RR,RTHCUTEN &
- & ,T_PHY,TH_PHY &
- & ,U_PHY,V_PHY,WINT
-!
- REAL,DIMENSION(IMS:IME,JMS:JME,ENSDIM) :: ZERO_GD
-!
- REAL,DIMENSION(:,:,:,:),ALLOCATABLE :: MOIST_TRANS
-!
- REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: CLDFRA_DP, CLDFRA_SH
- REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: QC_CU, QI_CU
-!
- LOGICAL :: RESTART,WARM_RAIN,ETAMP_Regional, have_tg_tp, have_swath
- LOGICAL,DIMENSION(IMS:IME,JMS:JME) :: CU_ACT_FLAG
-!
- CHARACTER(LEN=255) :: message
-!
-!-----------------------------------------------------------------------
-!*** FOR TEMPERATURE CHANGE CHECK ONLY.
-!-----------------------------------------------------------------------
- INTEGER :: DTEMP_CHECK=2.0
- REAL :: TCHANGE
-! random number restart
- INTEGER, SAVE :: nfirst
- data nfirst /0/
-#if (NMM_CORE==1)
- INTEGER :: IDT
- REAL, DIMENSION(2) :: RND1
-#endif
-#if HWRF==1
- logical :: pert_sas
- integer :: ens_random_seed
- real :: ens_sasamp
-#endif
-!-----------------------------------------------------------------------
-!***********************************************************************
-!-----------------------------------------------------------------------
-!
-!-----------------------------------------------------------------------
-!*** RESET THE HBOT/HTOP CONVECTIVE CLOUD BOTTOM (BASE) AND TOP ARRAYS
-!*** USED IN RADIATION. THEY STORE THE MAXIMUM VERTICAL LIMITS OF
-!*** CONVECTIVE CLOUD BETWEEN RADIATION CALLS. CUPPT IS THE ACCUMULATED
-!*** CONVECTIVE PRECIPITATION BETWEEN RADIATION CALLS.
-!-----------------------------------------------------------------------
-!
-! Biswas's doing
- DO J=MYJS,MYJE
- DO I=MYIS,MYIE
-! DO J=JMS,JME
-! DO I=IMS,IME
- HFX(I,J)=0.
- QFX(I,J)=0.
- ENDDO
- ENDDO
-!End
-
- IF(MOD(NTSD,NRADS)==0.OR.MOD(NTSD,NRADL)==0)THEN
- DO J=JMS,JME
- DO I=IMS,IME
- HTOP(I,J)=0.
- HTOPD(I,J)=0.
- HTOPS(I,J)=0.
- HBOT(I,J)=REAL(KTE+1)
- HBOTD(I,J)=REAL(KTE+1)
- HBOTS(I,J)=REAL(KTE+1)
- CUTOP(I,J)=0.
- CUBOT(I,J)=REAL(KTE+1)
- CUPPT(I,J)=0.
- ENDDO
- ENDDO
- ENDIF
-!-----------------------------------------------------------------------
- IF(MOD(NTSD,NCNVC)/=0.AND. &
- & CONFIG_FLAGS%CU_PHYSICS==BMJSCHEME)RETURN
- IF(MOD(NTSD,NCNVC)/=0.AND. &
- & CONFIG_FLAGS%CU_PHYSICS==KSASSCHEME)RETURN
- IF(MOD(NTSD,NCNVC)/=0.AND. &
- & CONFIG_FLAGS%CU_PHYSICS==NSASSCHEME)RETURN
- IF(MOD(NTSD,NCNVC)/=0.AND. &
- & CONFIG_FLAGS%CU_PHYSICS==TIEDTKESCHEME)RETURN
- IF(MOD(NTSD,NCNVC)/=0.AND. &
- & CONFIG_FLAGS%CU_PHYSICS==OSASSCHEME)RETURN
- IF(MOD(NTSD,NCNVC)/=0.AND. &
- & CONFIG_FLAGS%CU_PHYSICS==SASSCHEME)RETURN
- IF(MOD(NTSD,NCNVC)/=0.AND. &
- & CONFIG_FLAGS%CU_PHYSICS==SCALESASSCHEME)RETURN
-
-!-----------------------------------------------------------------------
- NSTEP_CNV=NCNVC
-!
- RESTART=RESTRT
-!-----------------------------------------------------------------------
- IF(CONFIG_FLAGS%CU_PHYSICS==KFETASCHEME)THEN
-!
- IF(.NOT.RESTART.AND.NTSD==0)THEN
-!$omp parallel do &
-!$omp& private(i,j,k)
- DO J=JTS,JTE
- DO K=KTS,KTE
- DO I=ITS,ITE
- W0AVG(I,K,J)=0.
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-!
- ENDIF
-!
-!-----------------------------------------------------------------------
-!*** GENERAL PREPARATION
-!-----------------------------------------------------------------------
-!
- AVCNVC=AVCNVC+1.
- ACUTIM=ACUTIM+1.
-!
- DTCNVC=NCNVC*DT
- RDTCNVC=1./DTCNVC
- CAPA=R_D/CP
- G_INV=1./G
-!
-!$omp parallel do &
-!$omp& private(I,J)
- DO J=MYJS2,MYJE2
- DO I=MYIS1,MYIE1
-!
- PDSL(I,J)=PD(I,J)*RES(I,J)
- RAINCV(I,J)=0.
- RAINC(I,J)=0.
- P8W(I,KTS,J)=PD(I,J)+PDTOP+PT
- LOWLYR(I,J)=KTS !<---- The lowest model layer counted from the bottom.
- XLAND(I,J)=SM(I,J)+1.
- NCA(I,J)=0.
- SFCZ(I,J)=FIS(I,J)*G_INV
-!
-!Biswas's doing
- HFX(I,J)=-TWBS(I,J)
- QFX(I,J)=-QWBS(I,J)/XLV
-!End
-
- CUTOP(I,J)=HTOP(I,J)
- CUBOT(I,J)=HBOT(I,J)
-!
-!*** LPBL IS THE MODEL LAYER CONTAINING THE PBL TOP
-!*** COUNTING DOWNWARD FROM THE TOP OF THE DOMAIN
-!*** SO KPBL IS THE SAME LAYER COUNTING UPWARD FROM
-!*** THE GROUND.
-!
- KPBL(I,J)=KTE-LPBL(I,J)+1
- ENDDO
- ENDDO
-!
-!$omp parallel do &
-!$omp& private(dpl,fice,frain,i,j,k,plyr,qi,ql,qr,qw,wc)
- DO J=MYJS2,MYJE2
- DO K=KTS,KTE
- DO I=MYIS1,MYIE1
- DPL=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
- QL(K)=MAX(Q(I,J,K),EPSQ)
- PLYR=AETA1(K)*PDTOP+AETA2(K)*PDSL(I,J)+PT
- PLYRB=AETA1(K)*PDTOP+AETA2(K)*(1.E5-PDTOP)+PT
- ZNU(K)=(PLYRB-PT)/1.E5
- TL(K)=T(I,J,K)
-!
- RR(I,K,J)=PLYR/(R_D*TL(K)*(P608*QL(K)+1.))
- T_PHY(I,K,J)=TL(K)
-
- TH_PHY(I,K,J)=TL(K)*(1.E5/PLYR)**CAPA
-!!! P8W(I,KFLIP,J)=PINT(I,J,K+1)
- P8W(I,K+1,J)=ETA1(K+1)*PDTOP+ETA2(K+1)*PDSL(I,J)+PT
- P_PHY(I,K,J)=PLYR
- PI_PHY(I,K,J)=(PLYR*1.E-5)**CAPA
-!
- ENDDO
-!
- ENDDO
- ENDDO
-
-!$omp parallel do &
-!$omp& private(i,j,k)
- DO J=JTS,JTE
- DO K=KTS,KTE
- DO I=ITS,ITE
- RTHCUTEN(I,K,J)=0.
- RQVCUTEN(I,K,J)=0.
- RQCCUTEN(I,K,J)=0.
- RQRCUTEN(I,K,J)=0.
- RQICUTEN(I,K,J)=0.
- RQSCUTEN(I,K,J)=0.
- ENDDO
- ENDDO
- ENDDO
-#if (NMM_CORE==1)
-!$omp parallel do &
-!$omp& private(i,j,k)
- DO K=KTS,KTE
- DO J=JTS,JTE
- DO I=ITS,ITE
- DUCUDT(i,j,k)=0.0
- DVCUDT(i,j,k)=0.0
- DTHCUDT(i,j,k)=0.0
- DQVCUDT(i,j,k)=0.0
- DQRCUDT(i,j,k)=0.0
- DQCCUDT(i,j,k)=0.0
- DQICUDT(i,j,k)=0.0
- DQSCUDT(i,j,k)=0.0
- ENDDO
- ENDDO
- ENDDO
-#endif
-
-!
-!-----------------------------------------------------------------------
-!
-
- IF(.NOT.HYDRO)THEN
-!$omp parallel do &
-!$omp& private(i,j,k)
- DO K=KTS,KTE
- DO J=MYJS2,MYJE2
- DO I=MYIS1,MYIE1
- DZ(I,K,J)=Z(I,J,K+1)-Z(I,J,K)
- ENDDO
- ENDDO
- ENDDO
-!
- IF(NTSD==0)THEN
-!$omp parallel do &
-!$omp& private(i,j,k)
- DO J=MYJS2,MYJE2
- DO K=KTS,KTE+1 ! zero for all interfaces
- DO I=MYIS1,MYIE1
- WINT(I,K,J)=0.
- ENDDO
- ENDDO
- ENDDO
-
- ELSE ! not NTSD=0
-
- DO J=MYJS2,MYJE2
- DO I=MYIS1,MYIE1
- WINT(I,KTS,J)=0.
- WINT(I,KTE+1,J)=0.
- ENDDO
- ENDDO
-
- DO J=MYJS2,MYJE2
- DO K=KTS+1,KTE
- DO I=MYIS1,MYIE1
- WINT(I,K,J)=0.5*(W(I,J,K)+W(I,J,K-1))
- ENDDO
- ENDDO
- ENDDO
-
- ENDIF
-
- ELSE ! hydrostatic
-
- DO J=MYJS2,MYJE2
- DO I=MYIS1,MYIE1
- WINT(I,KTS,J)=0.
- WINT(I,KTE+1,J)=0.
- ENDDO
- ENDDO
-!
-!$omp parallel do &
-!$omp& private(i,j,k,plyr)
- DO J=MYJS2,MYJE2
- DO I=MYIS1,MYIE1
- WMID_L(I,J)=-OMGALF(I,J,KTS)*CP/(G*DT)
- PDSL(I,J)=PD(I,J)*RES(I,J)
- PLYR=AETA1(KTS)*PDTOP+AETA2(KTS)*PDSL(I,J)+PT
- DZ(I,KTS,J)=T(I,J,KTS)*(P608*Q(I,J,KTS)+1.)*R_D &
- & *(P8W(I,KTS,J)-P8W(I,KTS+1,J)) &
- & /(PLYR*G)
- ENDDO
- ENDDO
-!
-!$omp parallel do &
-!$omp& private(i,j,k,ql_k,tl_k,wmid)
- DO J=MYJS2,MYJE2
- DO K=KTS+1,KTE
- DO I=MYIS1,MYIE1
- TL_K=T_PHY(I,K,J)
- QL_K=MAX(Q(I,J,K),EPSQ)
- WMID=-OMGALF(I,J,K)*CP/(G*DT)
- WINT(I,K,J)=0.5*(WMID_L(I,J)+WMID)
- WMID_L(I,J)=WMID
- DZ(I,K,J)=TL_K*(P608*QL_K+1.)*R_D &
- & *(P8W(I,K,J)-P8W(I,K+1,J)) &
- & /(P_PHY(I,K,J)*G)
- ENDDO
- ENDDO
- ENDDO
-!
- ENDIF
-!
-!-----------------------------------------------------------------------
-!*** COMPUTE VELOCITY COMPONENTS AT MASS POINTS
-!-----------------------------------------------------------------------
-!
- IF(CONFIG_FLAGS%CU_PHYSICS/=BMJSCHEME)THEN
-!
-!$omp parallel do &
-!$omp& private(i,j,k)
- DO K=KTS,KTE
-!
- DO J=MYJS1_P1,MYJE1_P1
- DO I=MYIS_P1,MYIE_P1
- U_PHY(I,K,J)=(U(I+IHE(J),J,K)+U(I+IHW(J),J,K) &
- & +U(I,J+1,K)+U(I,J-1,K)) &
- & *0.25
- V_PHY(I,K,J)=(V(I+IHE(J),J,K)+V(I+IHW(J),J,K) &
- & +V(I,J+1,K)+V(I,J-1,K)) &
- & *0.25
- ENDDO
- ENDDO
-!
- ENDDO
-!
- ENDIF
-!
-!-----------------------------------------------------------------------
-!*** TRANSPOSE THE MOIST ARRAY (IJK) FOR THE PHYSICS (IKJ).
-!-----------------------------------------------------------------------
-!
- IF(.NOT.ALLOCATED(MOIST_TRANS))THEN
- ALLOCATE(MOIST_TRANS(IMS:IME,KMS:KME,JMS:JME,N_MOIST),STAT=ISTAT)
- ENDIF
-!
- DO N=1,N_MOIST
-!$omp parallel do &
-!$omp& private(i,j,k)
- DO K=KMS,KME
- DO J=JMS,JME
- DO I=IMS,IME
- MOIST_TRANS(I,K,J,N)=MOIST(I,J,K,N)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-
-
- CALL SET_TILES(GRID,IDS+1,IDE-1,JDS+2,JDE-2,ITS,ITE,JTS,JTE)
-#if HWRF==1
- CALL nl_get_pert_sas(1,pert_sas)
- CALL nl_get_ens_random_seed(1,ens_random_seed)
- CALL nl_get_ens_sasamp(1,ens_sasamp)
-#endif
-
-#if (NMM_CORE==1)
-!$omp parallel do &
-!$omp& private(i,j,k)
- DO K=KMS,KME
- DO J=JMS,JME
- DO I=IMS,IME
- DUCUDT(i,j,k)=0.0
- DVCUDT(i,j,k)=0.0
- DTHCUDT(i,j,k)=0.0
- DQVCUDT(i,j,k)=0.0
- DQRCUDT(i,j,k)=0.0
- DQCCUDT(i,j,k)=0.0
- DQICUDT(i,j,k)=0.0
- DQSCUDT(i,j,k)=0.0
- ENDDO
- ENDDO
- ENDDO
-#endif
- CALL CUMULUS_DRIVER(GRID &
- & ,IDS=IDS,IDE=IDE,JDS=JDS,JDE=JDE,KDS=KDS,KDE=KDE &
- & ,IMS=IMS,IME=IME,JMS=JMS,JME=JME,KMS=KMS,KME=KME &
- & ,IPS=ips,IPE=ipe,JPS=jps,JPE=jpe,KPS=kps,KPE=kpe &
- & ,I_START=GRID%I_START,I_END=GRID%I_END &
- & ,J_START=GRID%J_START,J_END=GRID%J_END &
- & ,KTS=KTS,KTE=KTE,NUM_TILES=GRID%NUM_TILES &
- ! Prognostic
- & ,U=U_PHY,V=V_PHY,TH=TH_PHY,T=T_PHY,W=WINT &
- & ,P=P_PHY,PI=PI_PHY,RHO=RR,W0AVG=W0AVG &
- ! Others
- & ,ITIMESTEP=NTSD,DT=DT,DX=GPS &
- & ,RAINC=RAINC,RAINCV=RAINCV,NCA=NCA &
- & ,CLDFRA_DP=CLDFRA_DP,CLDFRA_SH=CLDFRA_SH &
- & ,CCLDFRA=grid%ccldfra, CONVCLD=grid%convcld &
- & ,QCCONV=grid%qcconv, QICONV=grid%qiconv &
- & ,QC_CU=QC_CU, QI_CU=QI_CU &
- & ,DZ8W=DZ,P8W=P8W,FORCET=TTEN,FORCEQ=QTEN &
- & ,CLDEFI=CLDEFI,LOWLYR=LOWLYR,XLAND=XLAND &
- & ,CU_ACT_FLAG=CU_ACT_FLAG,WARM_RAIN=WARM_RAIN &
-! kf_edrates
- & ,UDR_KF=grid%udr_kf,DDR_KF=grid%ddr_kf &
- & ,UER_KF=grid%uer_kf,DER_KF=grid%der_kf &
- & ,TIMEC_KF=grid%timec_kf &
- & ,KF_EDRATES=config_flags%kf_edrates &
-!Biswas
- & ,HFX=HFX,QFX=QFX,PBLH=PBLH &
- & ,HPBL_HOLD=HPBL_HOLD &
- & ,ZNU=ZNU &
- & ,STEPCU=NSTEP_CNV,GSW=GSW &
- & ,PERIODIC_X=.FALSE.,PERIODIC_Y=.FALSE. &
- & ,HTOP=CUTOP,HBOT=CUBOT,KPBL=KPBL,HT=SFCZ,Z=Z &
- & ,APR_GR=APR_GR,APR_W=APR_W,APR_MC=APR_MC &
- & ,APR_ST=APR_ST,APR_AS=APR_AS,APR_CAPMA=APR_CAPMA &
- & ,APR_CAPME=APR_CAPME,APR_CAPMI=APR_CAPMI &
- & ,MASS_FLUX=MASS_FLUX,XF_ENS=XF_ENS &
- & ,PR_ENS=PR_ENS &
- & ,GD_CLOUD=GD_CLOUD,GD_CLOUD2=GD_CLOUD2 &
- & ,KTOP_DEEP=KTOP_DEEP &
- & ,ENSDIM=ENSDIM,MAXIENS=1,MAXENS=3 &
- & ,MAXENS2=3,MAXENS3=16 &
- & ,RTHCUTEN=RTHCUTEN,RQVCUTEN=RQVCUTEN &
- & ,RQCCUTEN=RQCCUTEN,RQRCUTEN=RQRCUTEN &
- & ,RQICUTEN=RQICUTEN,RQSCUTEN=RQSCUTEN &
- & ,RTHBLTEN=RTHBLTEN,RQVBLTEN=RQVBLTEN &
- & ,RTHRATEN=RTHRATEN &
-#if (NMM_CORE==1)
- & ,RUCUTEN=DUCUDT, RVCUTEN=DVCUDT, MOMMIX=MOMMIX &
- ,store_rand=store_rand &
-#if (HWRF==1)
- & ,pert_sas=pert_sas &
- & ,ens_random_seed=ens_random_seed &
- & ,ens_sasamp=ens_sasamp &
-#endif
-#endif
- & ,SHALL=grid%shall &
- & ,HPBL2D=HPBL2D,EVAP2D=EVAP2D,HEAT2D=HEAT2D &
- & ,DX2D=DX2D,DYNMM=DYNMM & ! scale-sware SAS
- & ,SCALEFUN=SCALEFUN, SCALEFUN1=SCALEFUN1 & ! scale function
- & ,SIGMU=SIGMU, SIGMU1=SIGMU1 & ! updraft fraction
-
- & ,pgcon=config_flags%sas_pgcon &
- & ,sas_mass_flux=config_flags%sas_mass_flux &
- & ,shalconv=config_flags%sas_shal_conv &
- & ,shal_pgcon=config_flags%sas_shal_pgcon &
- & ,IS_CAMMGMP_USED=IS_CAMMGMP_USED &
- & ,BMJ_RAD_FEEDBACK=config_flags%bmj_rad_feedback &
- ! Selection argument
- & ,CU_PHYSICS=CONFIG_FLAGS%CU_PHYSICS &
- & ,MP_PHYSICS=CONFIG_FLAGS%MP_PHYSICS &
- ! Moisture tracer arguments
- & ,QV_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QV),F_QV=F_QV &
- & ,QC_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QC),F_QC=F_QC &
- & ,QR_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QR),F_QR=F_QR &
- & ,QI_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QI),F_QI=F_QI &
- & ,QS_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QS),F_QS=F_QS &
- & ,QG_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QG),F_QG=F_QG)
-!
-#if (NMM_CORE==1)
-!$omp parallel do &
-!$omp& private(i,j,k)
- DO K=KMS,KME
- DO J=JMS,JME
- DO I=IMS,IME
- DTHCUDT(i,j,k)=RTHCUTEN(i,k,j)
- DQVCUDT(i,j,k)=RQVCUTEN(i,k,j)
- DQRCUDT(i,j,k)=RQRCUTEN(i,k,j)
- DQCCUDT(i,j,k)=RQCCUTEN(i,k,j)
- DQICUDT(i,j,k)=RQICUTEN(i,k,j)
- DQSCUDT(i,j,k)=RQSCUTEN(i,k,j)
- ENDDO
- ENDDO
- ENDDO
-#endif
-
-!-----------------------------------------------------------------------
-!
-!*** CNVTOP/CNVBOT HOLD THE MAXIMUM VERTICAL LIMITS OF CONVECTIVE CLOUD
-!*** BETWEEN HISTORY OUTPUT TIMES. HBOTS/HTOPS STORE SIMILIAR INFORMATION
-!*** FOR SHALLOW (NONPRECIPITATING) CONVECTION, AND HBOTD/HTOPD ARE FOR
-!*** DEEP (PRECIPITATING) CONVECTION.
-!
- CF_HI=CONFIG_FLAGS%HISTORY_INTERVAL
-
- if(CF_HI<1e-5) then
- CF_HI = config_flags%history_interval_s/60. &
- + config_flags%history_interval_m &
- + config_flags%history_interval_h*3600. &
- + config_flags%history_interval_d*3600.*24.
- endif
-
- N_TIMSTPS_OUTPUT=NINT(60.*CF_HI/DT)
- MNTO=MOD(NTSD,max(1,N_TIMSTPS_OUTPUT))
-!
- IF(MNTO>0.AND.MNTO<=NCNVC)THEN
- DO J=MYJS2,MYJE2
- IENDX=MYIE1
- IF(MOD(J,2)==0.AND.ITE==IDE-1)IENDX=IENDX-1
- DO I=MYIS1,IENDX
- CNVBOT(I,J)=REAL(KTE+1.)
- CNVTOP(I,J)=0.
- HBOTD(I,J)=REAL(KTE+1.)
- HTOPD(I,J)=0.
- HBOTS(I,J)=REAL(KTE+1.)
- HTOPS(I,J)=0.
- ENDDO
- ENDDO
- ENDIF
-!
-!-----------------------------------------------------------------------
-!
-
- have_tg_tp = .false.
- have_swath = .false.
- have_tg_tp = (size(grid%tg_total_precip)>1)
-#if ( HWRF == 1 )
- have_swath = ( size(grid%precip_swath)>1 )
-#endif
-!$omp parallel do &
-!$omp& private(i,iendx,j,ncubot,ncutop,pcpcol)
- pcp_cloud: DO J=MYJS2,MYJE2
- IENDX=MYIE1
- IF(MOD(J,2)==0.AND.ITE==IDE-1)IENDX=IENDX-1
- DO I=MYIS1,IENDX
-!
-!*** UPDATE PRECIPITATION
-!
- PCPCOL=RAINCV(I,J)*1.E-3*NSTEP_CNV
- PREC(I,J)=PREC(I,J)+PCPCOL
- ACPREC(I,J)=ACPREC(I,J)+PCPCOL
- CUPREC(I,J)=CUPREC(I,J)+PCPCOL
- CUPPT(I,J)=CUPPT(I,J)+PCPCOL
- CPRATE(I,J)=PCPCOL
- if(have_tg_tp) then
- grid%tg_total_precip(i,j) = grid%tg_total_precip(i,j) + PCPCOL
- endif
-#if ( HWRF == 1 )
- if(have_swath) then
- if(grid%interesting(i,j)/=0) then
- grid%precip_swath(i,j) = grid%precip_swath(i,j) + PCPCOL
- if(size(grid%cuprecip_swath)>0) then
- grid%cuprecip_swath(i,j) = grid%cuprecip_swath(i,j) + PCPCOL
- endif
- endif
- endif
-#endif
-!
-!*** SAVE CLOUD TOP AND BOTTOM FOR RADIATION (HTOP/HBOT) AND
-!*** FOR OUTPUT (CNVTOP/CNVBOT, HTOPS/HBOTS, HTOPD/HBOTD) ARRAYS.
-!*** THEY MUST BE TREATED SEPARATELY FROM EACH OTHER.
-!
- CUTOP(I,J)=MIN(CUTOP(I,J),REAL(KDE))
- CUTOP(I,J)=MAX(CUTOP(I,J),0.0)
- CUBOT(I,J)=MIN(CUBOT(I,J),REAL(KDE))
- CUBOT(I,J)=MAX(CUBOT(I,J),0.0)
-
- NCUTOP=NINT(CUTOP(I,J))
- NCUBOT=NINT(CUBOT(I,J))
-!
- IF(NCUTOP>1.AND.NCUTOP0.)THEN
- HTOPD(I,J)=MAX(CUTOP(I,J),HTOPD(I,J))
- ELSE
- HTOPS(I,J)=MAX(CUTOP(I,J),HTOPS(I,J))
- ENDIF
- ENDIF
-!
- IF(NCUBOT>0.AND.NCUBOT0.)THEN
- HBOTD(I,J)=MIN(CUBOT(I,J),HBOTD(I,J))
- ELSE
- HBOTS(I,J)=MIN(CUBOT(I,J),HBOTS(I,J))
- ENDIF
- ENDIF
-!
- ENDDO
- ENDDO pcp_cloud
-!
-!-----------------------------------------------------------------------
-!*** UPDATE TEMPERATURE, SPECIFIC HUMIDITY, AND HEATING.
-!-----------------------------------------------------------------------
-!
-!-- ETAMP_Regional logical is true for regional NAM (ETAMPNEW) or HRW (ETAMPNEW) microphysics
-!
- ETAMP_Regional=.FALSE.
- IF (CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW .OR. &
- & CONFIG_FLAGS%MP_PHYSICS==FER_MP_HIRES) ETAMP_Regional=.TRUE.
-!
-!$omp parallel do &
-!$omp& private(dqdt,dtdt,i,iendx,j,k,tchange)
- DO K=KTS,KTE
- DO J=MYJS2,MYJE2
- IENDX=MYIE1
- IF(MOD(J,2)==0.AND.ITE==IDE-1)IENDX=IENDX-1
- DO I=MYIS1,IENDX
-!
-!*** RQVCUTEN IN BMJDRV IS THE MIXING RATIO TENDENCY,
-!*** SO RETRIEVE DQDT BY CONVERTING TO SPECIFIC HUMIDITY.
-!
- DQDT=RQVCUTEN(I,K,J)/(1.+MOIST_TRANS(I,K,J,P_QV))**2
-!
-!*** RTHCUTEN IN BMJDRV IS DTDT OVER PI.
-!
- DTDT=RTHCUTEN(I,K,J)*PI_PHY(I,K,J)
- T(I,J,K)=T(I,J,K)+DTDT*DTCNVC
- Q(I,J,K)=Q(I,J,K)+DQDT*DTCNVC
- TCUCN(I,J,K)=TCUCN(I,J,K)+DTDT
- MOIST_TRANS(I,K,J,P_QV)=Q(I,J,K)/(1.-Q(I,J,K)) !Convert to mixing ratio
-!
- cps_select: SELECT CASE(config_flags%cu_physics)
-!
- CASE (KFSCHEME,KFETASCHEME,GDSCHEME,SASSCHEME,SCALESASSCHEME,OSASSCHEME,KSASSCHEME,NSASSCHEME,TIEDTKESCHEME)
- IF(config_flags%mp_physics==fer_mp_hires_advect) THEN
- ! Update QI and QRIMEF:
- call QITEND_FER_HIRES_ADVECT( &
- MOIST_TRANS(I,K,J,P_QI), &
- SCALAR(I,J,K,P_QRIMEF), &
- RQICUTEN(I,K,J)*DTCNVC)
- ELSEIF (ETAMP_Regional) THEN
- MOIST_TRANS(I,K,J,P_QS)=MAX(0.,MOIST_TRANS(I,K,J,P_QS)+RQICUTEN(I,K,J)*DTCNVC+RQSCUTEN(I,K,J)*DTCNVC)
- ELSE
- MOIST_TRANS(I,K,J,P_QI)=MAX(0.,MOIST_TRANS(I,K,J,P_QI)+RQICUTEN(I,K,J)*DTCNVC)
- MOIST_TRANS(I,K,J,P_QS)=MAX(0.,MOIST_TRANS(I,K,J,P_QS)+RQSCUTEN(I,K,J)*DTCNVC)
- ENDIF
- MOIST_TRANS(I,K,J,P_QR)=MAX(0.,MOIST_TRANS(I,K,J,P_QR)+RQRCUTEN(I,K,J)*DTCNVC)
- MOIST_TRANS(I,K,J,P_QC)=MAX(0.,MOIST_TRANS(I,K,J,P_QC)+RQCCUTEN(I,K,J)*DTCNVC)
- END SELECT cps_select
-!
- TCHANGE=DTDT*DTCNVC
- IF(ABS(TCHANGE)>DTEMP_CHECK)THEN
- WRITE(message,*)'BIG T CHANGE BY CONVECTION=',TCHANGE &
- ,' AT (',I,',',J,',',K,') FOR NTSD=',NTSD
- CALL wrf_message(trim(message))
- ENDIF
-!
- ENDDO
- ENDDO
- ENDDO
-!-----------------------------------------------------------------------
-!*** REFILL THE MOIST ARRAY.
-!-----------------------------------------------------------------------
-!
- DO N=1,N_MOIST
-!$omp parallel do &
-!$omp& private(i,j,k)
- DO J=JMS,JME
- DO K=KMS,KME
- DO I=IMS,IME
- MOIST(I,J,K,N)=MOIST_TRANS(I,K,J,N)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-!
-!-----------------------------------------------------------------------
-!
- DEALLOCATE(MOIST_TRANS,STAT=ISTAT)
-!
-!-----------------------------------------------------------------------
-!
- END SUBROUTINE CUCNVC
-!
-!-----------------------------------------------------------------------
-!***********************************************************************
- SUBROUTINE GSMDRIVE(NTSD,DT,NPHS,N_MOIST &
- & ,DX,DY,SM,HBM2,FIS &
- & ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2 &
- & ,PDTOP,PT,PD,RES,PINT,T,Q,CWM,TRAIN &
- & ,MOIST,SCALAR,N_SCALAR &
- & ,F_ICE,F_RAIN,F_RIMEF,SR &
- & ,PREC,ACPREC,AVRAIN &
- & ,MP_RESTART_STATE &
- & ,TBPVS_STATE &
- & ,TBPVS0_STATE &
- & ,GRID,CONFIG_FLAGS &
- & ,re_cloud,re_ice,re_snow & ! G. Thompson
- & ,has_reqc,has_reqi,has_reqs & ! G. Thompson
- & ,diag_flag &
- & ,IDS,IDE,JDS,JDE,KDS,KDE &
- & ,IMS,IME,JMS,JME,KMS,KME &
- & ,ITS,ITE,JTS,JTE,KTS,KTE)
-!***********************************************************************
-!$$$ SUBPROGRAM DOCUMENTATION BLOCK
-! . . .
-! SUBPROGRAM: GSMDRIVE MICROPHYSICS OUTER DRIVER
-! PRGRMMR: BLACK ORG: W/NP22 DATE: 02-03-26
-!
-! ABSTRACT:
-! GSMDRIVE DRIVES THE MICROPHYSICS SCHEMES
-!
-! PROGRAM HISTORY LOG:
-! 02-03-26 BLACK - ORIGINATOR
-! 04-11-18 BLACK - THREADED
-! 05-12-19 BLACK - CONVERTED FROM IKJ TO IJK
-!
-! USAGE: CALL GSMDRIVE FROM SOLVE_NMM
-!
-! ATTRIBUTES:
-! LANGUAGE: FORTRAN 90
-! MACHINE : IBM
-!$$$
-!-----------------------------------------------------------------------
-!
- IMPLICIT NONE
-!
-!-----------------------------------------------------------------------
-!
- INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
- & ,IMS,IME,JMS,JME,KMS,KME &
- & ,ITS,ITE,JTS,JTE,KTS,KTE &
- & ,N_MOIST,N_SCALAR,NPHS,NTSD
-!
- REAL,INTENT(IN) :: DT,DX,DY,PDTOP,PT
-!
- REAL,INTENT(INOUT) :: AVRAIN
-!
- REAL,DIMENSION(KMS:KME-1),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
- REAL,DIMENSION(KMS:KME),INTENT(IN) :: ETA1,ETA2
-!
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: FIS,HBM2,PD,RES,SM
-!
- REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: PINT
-!
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ACPREC,PREC
-!
- REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: CWM,Q &
- & ,T,TRAIN
-!
- REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: F_ICE & !<--- Used only with physics (IKJ)
- & ,F_RAIN &
- & ,F_RIMEF
-
- REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,N_MOIST) &
- & ,INTENT(INOUT) :: MOIST
- REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,N_SCALAR) &
- & ,INTENT(INOUT) :: SCALAR
-!
-!*** State var for etampnew microphysics (JM, 2005 05 02)
-!
- REAL,DIMENSION(:),INTENT(INOUT) :: MP_RESTART_STATE &
- & ,TBPVS_STATE,TBPVS0_STATE
-!
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: SR
-!
-!..Additions for coupling cloud physics effective radii and radiation. G. Thompson
- REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT):: re_cloud, re_ice, re_snow
- INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs
-!
- TYPE(DOMAIN),TARGET :: GRID
-!
- TYPE(GRID_CONFIG_REC_TYPE),INTENT(IN) :: CONFIG_FLAGS
-!
-!-----------------------------------------------------------------------
-!*** LOCAL VARIABLES
-!-----------------------------------------------------------------------
-!
- INTEGER :: I,IENDX,IJ,ISTAT,J,K,N
-!
- INTEGER,DIMENSION(IMS:IME,JMS:JME) :: LOWLYR
-!
- REAL :: CAPA,DPL,DTPHS,PCPCOL,PLYR,RDTPHS,RG,TNEW
-!
- REAL,DIMENSION(KMS:KME-1) :: QL,TL
-!
- REAL,DIMENSION(IMS:IME,JMS:JME) :: CUBOT,CUTOP,PDSL &
- & ,RAINNC,RAINNCV,XLAND
-!
- REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: CWM_PHY,DZ &
- & ,P8W,P_PHY,PI_PHY &
- & ,RR,T_PHY,TH_PHY
-!
- REAL,DIMENSION(:,:,:,:),ALLOCATABLE :: MOIST_TRANS
- REAL,DIMENSION(:,:,:,:),ALLOCATABLE :: SCALAR_TRANS
- REAL,DIMENSION(:,:,:), ALLOCATABLE :: W_TRANS
-!
- LOGICAL :: diag_flag
- LOGICAL :: E_BDY,F_QT,QT_PRESENT,WARM_RAIN, have_tg_tp, have_swath
-!
-!-----------------------------------------------------------------------
-!***********************************************************************
-!-----------------------------------------------------------------------
-!
- ALLOCATE(MOIST_TRANS(IMS:IME,KMS:KME,JMS:JME,N_MOIST),STAT=ISTAT)
- ALLOCATE(SCALAR_TRANS(IMS:IME,KMS:KME,JMS:JME,N_SCALAR),STAT=ISTAT)
- ALLOCATE(W_TRANS(IMS:IME,KMS:KME,JMS:JME))
-!
-!-----------------------------------------------------------------------
-!*** TRANSPOSE THE MOIST ARRAY (IJK) FOR THE PHYSICS (IKJ).
-!-----------------------------------------------------------------------
-!
- DO N=2,N_MOIST
-!$omp parallel do &
-!$omp& private(i,j,k)
- DO K=KMS,KME
- DO J=JMS,JME
- DO I=IMS,IME
- MOIST_TRANS(I,K,J,N)=MOIST(I,J,K,N)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- do k=kts,kte
- do j=jts,jte
- do i=its,ite
- w_trans(i,k,j)=max(grid%w(i,j,k),grid%w_tot(i,j,k))
- enddo
- enddo
- enddo
-!
-!-----------------------------------------------------------------------
-!
-!-- QT_PRESENT logical is true for regional NAM (ETAMPNEW), HRW (ETAMPNEW),
-! or HWRF (ETAMP_HWRF) microphysics
-!
- QT_PRESENT=.FALSE.
- IF (CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW .OR. &
- & CONFIG_FLAGS%MP_PHYSICS==FER_MP_HIRES .OR. &
- & CONFIG_FLAGS%MP_PHYSICS==ETAMP_HWRF) QT_PRESENT=.TRUE.
-!
- micro_check1: IF(.NOT.QT_PRESENT) THEN
- DO N=2,N_SCALAR
-!$omp parallel do &
-!$omp& private(i,j,k)
- DO K=KMS,KME
- DO J=JMS,JME
- DO I=IMS,IME
- SCALAR_TRANS(I,K,J,N)=SCALAR(I,J,K,N)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- ENDIF micro_check1
-!
-!-----------------------------------------------------------------------
-!
- DTPHS=NPHS*DT
- RDTPHS=1./DTPHS
- CAPA=R_D/CP
- RG=1./G
- AVRAIN=AVRAIN+1.
-!
-!-----------------------------------------------------------------------
-!
-!*** PREPARE NEEDED ARRAYS
-!
-!-----------------------------------------------------------------------
-!$omp parallel do &
-!$omp& private(i,j)
- DO J=MYJS2,MYJE2
- DO I=MYIS1,MYIE1
-!
- PDSL(I,J)=PD(I,J)*RES(I,J)
- P8W(I,KTE+1,J)=PT
- LOWLYR(I,J)=KTS !<---- The lowest model layer counted from the bottom.
- XLAND(I,J)=SM(I,J)+1.
-!-----------------------------------------------------------------------
-!*** FILL RAINNC WITH ZERO (NORMALLY CONTAINS THE NONCONVECTIVE
-!*** ACCUMULATED RAIN BUT NOT YET USED BY NMM).
-!*** CAN BE OBTAINED FROM ACPREC AND CUPREC (ACPREC-CUPREC).
-!-----------------------------------------------------------------------
- RAINNC(I,J)=0.
-!
- ENDDO
- ENDDO
-!
-!-----------------------------------------------------------------------
-!*** FILL THE SINGLE-COLUMN INPUT
-!-----------------------------------------------------------------------
-!
-!$omp parallel do &
-!$omp& private(dpl,i,j,k,plyr,ql,tl)
- DO J=MYJS2,MYJE2
- DO K=KTS,KTE
- DO I=MYIS1,MYIE1
- DPL=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
- QL(K)=MAX(Q(I,J,K),EPSQ)
-!!! PLYR=AETA1(K)*PDTOP+AETA2(K)*PDSL(I,J)+PT
- PLYR=(PINT(I,J,K)+PINT(I,J,K+1))*0.5
- TL(K)=T(I,J,K)
-!
- RR(I,K,J)=PLYR/(R_D*TL(K)*(P608*QL(K)+1.))
- T_PHY(I,K,J)=TL(K)
- PI_PHY(I,K,J)=(PLYR*1.E-5)**CAPA
- TH_PHY(I,K,J)=TL(K)/PI_PHY(I,K,J)
-!!! P8W(I,KFLIP,J)=PINT(I,J,K+1)
- P8W(I,K,J)=ETA1(K)*PDTOP+ETA2(K)*PDSL(I,J)+PT
- P_PHY(I,K,J)=PLYR
- DZ(I,K,J)=DPL*RG/RR(I,K,J)
- CWM_PHY(I,K,J)=CWM(I,J,K)
- ENDDO
-!
- ENDDO
- ENDDO
-!-----------------------------------------------------------------------
-!
-!*** CALL MICROPHYSICS
-!
-!-----------------------------------------------------------------------
-!
- CALL SET_TILES(GRID,IDS+1,IDE-1,JDS+2,JDE-2,ITS,ITE,JTS,JTE)
-!
- CALL MICROPHYSICS_DRIVER( &
- & TH=TH_PHY,RHO=RR,PI_PHY=PI_PHY,P=P_PHY &
- & ,RAINNC=RAINNC,RAINNCV=RAINNCV &
- & ,DZ8W=DZ,P8W=P8W,DT=DTPHS,DX=DX,DY=DY &
- & ,W=w_trans &
- & ,MP_PHYSICS=CONFIG_FLAGS%MP_PHYSICS &
- & ,SPECIFIED=CONFIG_FLAGS%SPECIFIED &
- & .OR.CONFIG_FLAGS%NESTED &
- & ,SPEC_ZONE=0,WARM_RAIN=WARM_RAIN &
- & ,XLAND=XLAND,ITIMESTEP=NTSD-1 &
- & ,F_ICE_PHY=F_ICE,F_RAIN_PHY=F_RAIN &
- & ,F_RIMEF_PHY=F_RIMEF &
- & ,LOWLYR=LOWLYR,SR=SR &
- & ,QV_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QV),F_QV=F_QV &
- & ,QC_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QC),F_QC=F_QC &
- & ,QR_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QR),F_QR=F_QR &
- & ,QI_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QI),F_QI=F_QI &
- & ,QS_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QS),F_QS=F_QS &
- & ,QG_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QG),F_QG=F_QG &
- & ,QH_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QH),F_QH=F_QH &
- & , QNN_CURR=SCALAR_TRANS(ims,kms,jms,P_QNN), F_QNN=F_QNN &
- & , QNDROP_CURR=SCALAR_TRANS(ims,kms,jms,P_QNDROP), F_QNDROP=F_QNDROP &
- & , QNI_CURR=SCALAR_TRANS(ims,kms,jms,P_QNI), F_QNI=F_QNI &
- & , QNC_CURR=SCALAR_TRANS(ims,kms,jms,P_QNC), F_QNC=F_QNC &
- & , QNR_CURR=SCALAR_TRANS(ims,kms,jms,P_QNR), F_QNR=F_QNR &
- & , QNS_CURR=SCALAR_TRANS(ims,kms,jms,P_QNS), F_QNS=F_QNS &
- & , QNG_CURR=SCALAR_TRANS(ims,kms,jms,P_QNG), F_QNG=F_QNG &
- & , QNH_CURR=SCALAR_TRANS(ims,kms,jms,P_QNH), F_QNH=F_QNH & ! for milbrandt2mom and nssl_2mom
- & , QVOLG_CURR=SCALAR_TRANS(ims,kms,jms,P_QVOLG), F_QVOLG=F_QVOLG & ! for nssl_2mom
- & , QVOLH_CURR=SCALAR_TRANS(ims,kms,jms,P_QVOLH), F_QVOLH=F_QVOLH & ! for nssl_2mom
- & ,QRIMEF_CURR=SCALAR_TRANS(IMS,KMS,JMS,P_QRIMEF),F_QRIMEF=F_QRIMEF &
- & ,QT_CURR=CWM_PHY,F_QT=QT_PRESENT &
- & ,MP_RESTART_STATE=MP_RESTART_STATE &
- & ,TBPVS_STATE=TBPVS_STATE &
- & ,TBPVS0_STATE=TBPVS0_STATE &
- & ,IDS=IDS,IDE=IDE,JDS=JDS,JDE=JDE,KDS=KDS,KDE=KDE &
- & ,IMS=IMS,IME=IME,JMS=JMS,JME=JME,KMS=KMS,KME=KME &
- & ,I_START=GRID%I_START,I_END=GRID%I_END &
- & ,J_START=GRID%J_START,J_END=GRID%J_END &
- & ,KTS=KTS,KTE=KTE,NUM_TILES=GRID%NUM_TILES &
- & ,DO_RADAR_REF=config_flags%do_radar_ref &
- & ,DIAGFLAG=diag_flag &
- & ,ID=grid%id &
- & ,num_scalar=1 & !mchen temporary
- & ,refl_10cm=grid%refl_10cm & ! to calc. radar reflectivity
- & ,re_cloud=grid%re_cloud & ! G. Thompson
- & ,re_ice=grid%re_ice & ! G. Thompson
- & ,re_snow=grid%re_snow & ! G. Thompson
- & ,has_reqc=has_reqc & ! G. Thompson
- & ,has_reqi=has_reqi & ! G. Thompson
- & ,has_reqs=has_reqs & ! G. Thompson
- & ,ccn_conc=config_flags%ccn_conc &
- & ,aercu_opt=config_flags%aercu_opt &
- )
-
-!$omp parallel do &
-!$omp& private(ij)
- DO IJ=1,GRID%NUM_TILES
- CALL MICROPHYSICS_ZERO_OUTA( &
- MOIST_TRANS,N_MOIST,CONFIG_FLAGS &
- ,IDS,IDE,JDS,JDE,KDS,KDE &
- ,IMS,IME,JMS,JME,KMS,KME &
- ,GRID%I_START(IJ),GRID%I_END(IJ) &
- ,GRID%J_START(IJ),GRID%J_END(IJ) &
- ,KTS,KTE )
- ENDDO
-
-
-
-!
-!-----------------------------------------------------------------------
-!
- E_BDY=(ITE>=IDE)
-!
-!-----------------------------------------------------------------------
-!*** UPDATE TEMPERATURE, SPECIFIC HUMIDITY, CLOUD WATER, AND HEATING.
-!-----------------------------------------------------------------------
-!$omp parallel do &
-!$omp& private(i,iendx,j,k,tnew)
- DO K=KTS,KTE
- DO J=MYJS2,MYJE2
- IENDX=MYIE1
- IF(E_BDY.AND.MOD(J,2)==0)IENDX=IENDX-1
- DO I=MYIS1,IENDX
- TNEW=TH_PHY(I,K,J)*PI_PHY(I,K,J)
- TRAIN(I,J,K)=TRAIN(I,J,K)+(TNEW-T(I,J,K))*RDTPHS
- T(I,J,K)=TNEW
- Q(I,J,K)=MOIST_TRANS(I,K,J,P_QV)/(1.+MOIST_TRANS(I,K,J,P_QV))
- CWM(I,J,K)=CWM_PHY(I,K,J)
- ENDDO
- ENDDO
- ENDDO
-!
-!-----------------------------------------------------------------------
-!*** UPDATE PRECIPITATION.
-!*** NOTE: RAINNC IS ACCUMULATED INSIDE MICROPHYSICS BUT NMM ZEROES IT
-!*** OUT ABOVE SINCE IT IS ONLY A LOCAL ARRAY FOR NOW.
-!-----------------------------------------------------------------------
-!
-#if ( HWRF == 1 )
- have_swath = ( size(grid%precip_swath)>1 )
-#endif
- have_tg_tp = (size(grid%tg_total_precip)>1)
-!$omp parallel do &
-!$omp& private(i,iendx,j,pcpcol)
- DO J=MYJS2,MYJE2
- IENDX=MYIE1
- IF(E_BDY.AND.MOD(J,2)==0)IENDX=IENDX-1
- DO I=MYIS1,IENDX
- PCPCOL=RAINNCV(I,J)*1.E-3
- PREC(I,J)=PREC(I,J)+PCPCOL
- ACPREC(I,J)=ACPREC(I,J)+PCPCOL
- if(have_tg_tp) then
- grid%tg_total_precip(i,j) = grid%tg_total_precip(i,j) + PCPCOL
- endif
-#if ( HWRF == 1 )
- if(have_swath) then
- if(grid%interesting(i,j)/=0) &
- grid%precip_swath(i,j) = grid%precip_swath(i,j) + PCPCOL
- endif
-#endif
- ENDDO
- ENDDO
-!
-!-----------------------------------------------------------------------
-!*** REFILL THE MOIST ARRAY.
-!-----------------------------------------------------------------------
-!
- DO N=2,N_MOIST
-!$omp parallel do &
-!$omp& private(i,j,k)
- DO J=JMS,JME
- DO K=KMS,KME
- DO I=IMS,IME
- MOIST(I,J,K,N)=MOIST_TRANS(I,K,J,N)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-!
-!-----------------------------------------------------------------------
-!
- micro_check2: IF (.NOT.QT_PRESENT) THEN
- DO N=2,N_SCALAR
-!$omp parallel do &
-!$omp& private(i,j,k)
- DO J=JMS,JME
- DO K=KMS,KME
- DO I=IMS,IME
- SCALAR(I,J,K,N)=SCALAR_TRANS(I,K,J,N)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- ENDIF micro_check2
-!
-!-----------------------------------------------------------------------
-!
- DEALLOCATE(MOIST_TRANS,STAT=ISTAT)
- DEALLOCATE(SCALAR_TRANS,STAT=ISTAT)
-!
-!-----------------------------------------------------------------------
-!
- END SUBROUTINE GSMDRIVE
-!
-!-----------------------------------------------------------------------
-!***********************************************************************
- SUBROUTINE UPDATE_MOIST(MOIST,Q,CWM,F_ICE,F_RAIN,N_MOIST &
- & ,IDS,IDE,JDS,JDE,KDS,KDE &
- & ,IMS,IME,JMS,JME,KMS,KME &
- & ,ITS,ITE,JTS,JTE,KTS,KTE)
-!***********************************************************************
-!-----------------------------------------------------------------------
-!
- IMPLICIT NONE
-!
-!-----------------------------------------------------------------------
-!
- INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
- & ,IMS,IME,JMS,JME,KMS,KME &
- & ,ITS,ITE,JTS,JTE,KTS,KTE &
- & ,N_MOIST
-!
- REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: CWM,Q
-!
- REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: F_ICE & !<--- Used only with physics (IKJ)
- & ,F_RAIN
-!
- REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,N_MOIST),INTENT(OUT) :: MOIST
-!
-!-----------------------------------------------------------------------
-!*** LOCAL VARIABLES
-!-----------------------------------------------------------------------
-!
- INTEGER :: I,J,K
-!
- REAL :: FICE,FRAIN,QI,QR,QW,WC
-!
-!-----------------------------------------------------------------------
-!***********************************************************************
-!-----------------------------------------------------------------------
-!
- DO K=KTS,KTE
- DO J=MYJS,MYJE
- DO I=MYIS,MYIE
- MOIST(I,J,K,P_QV)=Q(I,J,K)/(1.-Q(I,J,K))
- WC=CWM(I,J,K)
- QI=0.
- QR=0.
- QW=0.
- FICE=F_ICE(I,K,J)
- FRAIN=F_RAIN(I,K,J)
-!
- IF(FICE>=1.)THEN
- QI=WC
- ELSEIF(FICE<=0.)THEN
- QW=WC
- ELSE
- QI=FICE*WC
- QW=WC-QI
- ENDIF
-!
- IF(QW>0..AND.FRAIN>0.)THEN
- IF(FRAIN>=1.)THEN
- QR=QW
- QW=0.
- ELSE
- QR=FRAIN*QW
- QW=QW-QR
- ENDIF
- ENDIF
-!
- MOIST(I,J,K,P_QC)=QW
- MOIST(I,J,K,P_QR)=QR
- MOIST(I,J,K,P_QI)=0.
- MOIST(I,J,K,P_QS)=QI
- MOIST(I,J,K,P_QG)=0.
- ENDDO
- ENDDO
- ENDDO
-!
-!-----------------------------------------------------------------------
-!
- END SUBROUTINE UPDATE_MOIST
-!
-!-----------------------------------------------------------------------
-!***********************************************************************
-!-----------------------------------------------------------------------
-!
- END MODULE MODULE_PHYSICS_CALLS
-!
-!-------------------------------------------------------------------
diff --git a/UTIL/wrfcmaq_twoway_coupler/external/makefile b/UTIL/wrfcmaq_twoway_coupler/external/makefile
deleted file mode 100644
index 9ac0d94eab..0000000000
--- a/UTIL/wrfcmaq_twoway_coupler/external/makefile
+++ /dev/null
@@ -1,70 +0,0 @@
-#makefile to build a wrf_io with netCDF
-
-OBJSL = wrf_io.o field_routines.o module_wrfsi_static.o
-OBJS = $(OBJSL)
-CODE = ext_ncd_get_dom_ti.code ext_ncd_get_var_td.code ext_ncd_get_var_ti.code ext_ncd_put_dom_ti.code ext_ncd_put_var_td.code ext_ncd_put_var_ti.code transpose.code
-FFLAGS = $(FCFLAGS) -I$(NETCDFPATH)/include -I../ioapi_share
-LIBS = $(LIB_LOCAL) -L$(NETCDFPATH)/lib -lnetcdf
-LIBFFS = $(LIB_LOCAL) -L$(NETCDFPATH)/lib -lnetcdff -lnetcdf $(NETCDF4_DEP_LIB)
-CPP1 = $(CPP) -P $(TRADFLAG)
-M4 = m4 -Uinclude -Uindex -Ulen
-AR = ar
-
-.SUFFIXES: .F90 .f .o .code
-
-all : libwrfio_nf.a
-
-libwrfio_nf.a: $(OBJS) $(CODE)
- /bin/rm -f $@
- if [ "$(AR)" != "lib.exe" ] ; then \
- $(AR) cr libwrfio_nf.a $(OBJSL) ; \
- else \
- $(AR) /out:libwrfio_nf.a $(OBJSL) ; \
- fi
- $(RANLIB) $@
-
-wrf_io.o: wrf_io.F90 $(CODE)
- grep nf_format_64bit $(NETCDFPATH)/include/netcdf.inc ;\
- a=$$? ; export a ; \
- if [ $$a -a "$$WRFIO_NCD_LARGE_FILE_SUPPORT" = "1" ] ; then \
- $(CPP1) -DWRFIO_NCD_LARGE_FILE_SUPPORT -I../ioapi_share wrf_io.F90 | $(M4) - > wrf_io.f ; \
- else \
- $(CPP1) -DWRFIO_NCD_LARGE_FILE_SUPPORT -I../ioapi_share wrf_io.F90 | $(M4) - > wrf_io.f ; \
- fi
- $(FC) -o $@ $(FFLAGS) -c wrf_io.f
-
-
-module_wrfsi_static.o: module_wrfsi_static.F90
- $(CPP1) -I../ioapi_share module_wrfsi_static.F90 > module_wrfsi_static.f
- $(FC) -o $@ $(FFLAGS) -c module_wrfsi_static.f
-
-# gfortran treats iargc as intrinsic, so get rid of external declaration in that case
-diffwrf: diffwrf.F90
- x=`echo "$(FC)" | awk '{print $$1}'` ; export x ; \
- if [ $$x = "gfortran" ] ; then \
- echo removing external declaration of iargc for gfortran ; \
- $(CPP1) -I$(NETCDFPATH)/include -I../ioapi_share diffwrf.F90 | sed '/integer *, *external.*iargc/d' > diffwrf.f ;\
- else \
- $(CPP1) -I$(NETCDFPATH)/include -I../ioapi_share diffwrf.F90 > diffwrf.f ; \
- fi
- $(FC) -c $(FFLAGS) diffwrf.f
- @if [ \( -f ../../frame/wrf_debug.o \) -a \( -f ../../frame/module_wrf_error.o \) -a \( -f $(ESMF_MOD_DEPENDENCE) \) -a \( -f ../../frame/clog.o \) ] ; then \
- echo "diffwrf io_netcdf is being built now. " ; \
- if [ \( -f $(NETCDFPATH)/lib/libnetcdff.a -o -f $(NETCDFPATH)/lib/libnetcdff.so -o -f $(NETCDFPATH)/lib/libnetcdff.dll.a \) ] ; then \
- $(FC) $(FFLAGS) $(LDFLAGS) -o diffwrf diffwrf.o $(OBJSL) ../../frame/wrf_debug.o ../../frame/module_wrf_error.o ../../frame/clog.o $(ESMF_IO_LIB_EXT) $(LIBFFS) ;\
- else \
- $(FC) $(FFLAGS) $(LDFLAGS) -o diffwrf diffwrf.o $(OBJSL) ../../frame/wrf_debug.o ../../frame/module_wrf_error.o ../../frame/clog.o $(ESMF_IO_LIB_EXT) $(LIBS) ;\
- fi ; \
- else \
- echo "***************************************************************************** " ; \
- echo "*** Rerun compile to make diffwrf in external/io_netcdf directory *** " ; \
- echo "***************************************************************************** " ; \
- fi
-
-field_routines.o: field_routines.F90 wrf_io.o
- $(CPP1) -I../ioapi_share field_routines.F90 > field_routines.f
- $(FC) -o $@ $(FFLAGS) -c field_routines.f
-
-superclean:
- @/bin/rm -f *.f *.o *.obj *.i testWRFWrite testWRFRead \
- *.mod libwrfio_nf.a diffwrf
diff --git a/UTIL/wrfcmaq_twoway_coupler/main/Makefile b/UTIL/wrfcmaq_twoway_coupler/main/Makefile
deleted file mode 100644
index e982c12ef0..0000000000
--- a/UTIL/wrfcmaq_twoway_coupler/main/Makefile
+++ /dev/null
@@ -1,70 +0,0 @@
-#
-
-LN = ln -sf
-MAKE = make -i -r
-RM = rm -f
-
-MODULES = module_wrf_top.F
-
-OBJS =
-
-LIBPATHS =
-
-include ../configure.wrf
-
-$(SOLVER)_wrf : wrf.o ../main/module_wrf_top.o
- $(RANLIB) $(RLFLAGS) $(LIBWRFLIB)
- $(LD) -o wrf.exe $(LDFLAGS) wrf.o ../main/module_wrf_top.o $(LIBWRFLIB) $(CMAQLIB) $(LIB)
-
-$(SOLVER)_wrfplus : wrf.o ../main/module_wrf_top.o
- $(RANLIB) $(RLFLAGS) $(LIBWRFLIB)
- $(LD) -o wrfplus.exe $(LDFLAGS) wrf.o ../main/module_wrf_top.o $(LIBWRFLIB) $(LIB)
-
-$(SOLVER)_wrf_SST_ESMF : wrf_ESMFMod.o wrf_SST_ESMF.o ../main/module_wrf_top.o
- $(RANLIB) $(RLFLAGS) $(LIBWRFLIB)
- $(LD) -o wrf_SST_ESMF.exe $(LDFLAGS) wrf_SST_ESMF.o wrf_ESMFMod.o ../main/module_wrf_top.o $(LIBWRFLIB) $(LIB)
-
-$(SOLVER)_ideal : module_initialize ideal_$(SOLVER).o
- $(RANLIB) $(RLFLAGS) $(LIBWRFLIB)
- $(LD) -o ideal.exe $(LDFLAGS) ideal_$(SOLVER).o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o $(LIBWRFLIB) $(LIB)
-
-$(SOLVER)_real : module_initialize ndown_$(SOLVER).o tc_$(SOLVER).o real_$(SOLVER).o
- $(RANLIB) $(RLFLAGS) $(LIBWRFLIB)
- $(LD) -o ndown.exe $(LDFLAGS) ndown_$(SOLVER).o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o $(LIBWRFLIB) $(LIB)
- $(LD) -o tc.exe $(LDFLAGS) tc_$(SOLVER).o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o $(LIBWRFLIB) $(LIB)
- $(LD) -o real.exe $(LDFLAGS) real_$(SOLVER).o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o $(LIBWRFLIB) $(LIB)
-
-convert_em : convert_em.o
- $(RANLIB) $(RLFLAGS) $(LIBWRFLIB)
- $(LD) -o convert_em.exe $(LDFLAGS) convert_em.o $(LIBWRFLIB) $(LIB)
-
-convert_nmm : convert_nmm.o
- $(RANLIB) $(RLFLAGS) $(LIBWRFLIB)
- $(FC) -o convert_nmm.exe $(LDFLAGS) convert_nmm.o $(LIBWRFLIB) $(LIB)
-
-real_nmm : real_nmm.o
- ( cd ../dyn_nmm ; $(MAKE) module_initialize_real.o )
- $(RANLIB) $(RLFLAGS) $(LIBWRFLIB)
- $(FC) -o real_nmm.exe $(LDFLAGS) real_nmm.o $(LIBWRFLIB) $(LIB)
-
-module_initialize : ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o
-# ( cd ../dyn_$(SOLVER) ; $(MAKE) module_initialize_$(IDEAL_CASE).o )
-
-## prevent real being compiled for OMP -- only for regtesting
-#$(SOLVER)_real : module_initialize real_$(SOLVER).o
-# $(RANLIB) $(RLFLAGS) $(LIBWRFLIB)
-# if [ -z "$(OMP)" ] ; then $(FC) -o real.exe $(LDFLAGS) real_$(SOLVER).o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o $(LIBWRFLIB) $(LIB) ; fi
-#
-## prevent module_initialize being compiled for OMP --remove after IBM debugging
-#module_initialize :
-# if [ -z "$(OMP)" ] ; then ( cd ../dyn_$(SOLVER) ; $(MAKE) module_initialize_$(IDEAL_CASE).o ) ; fi
-# end of regtest changes
-
-clean:
- @ echo 'use the clean script'
-
-# DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES)
-
-include depend.common
-
-# DO NOT DELETE
diff --git a/UTIL/wrfcmaq_twoway_coupler/main/depend.common b/UTIL/wrfcmaq_twoway_coupler/main/depend.common
deleted file mode 100644
index df819a41d4..0000000000
--- a/UTIL/wrfcmaq_twoway_coupler/main/depend.common
+++ /dev/null
@@ -1,1331 +0,0 @@
-# DEPENDENCIES for frame
-
-
-module_configure.o: \
- ../dyn_em/namelist_remappings_em.h \
- module_domain_type.o \
- module_state_description.o \
- module_wrf_error.o \
- module_driver_constants.o
-
-module_dm.o: module_machine.o module_state_description.o module_wrf_error.o \
- module_domain.o \
- module_driver_constants.o \
- module_timing.o \
- module_comm_nesting_dm.o \
- module_configure.o module_comm_dm.o \
- module_cpl.o \
- ../share/module_model_constants.o
-
-module_timing.o: hires_timer.o clog.o
-
-module_comm_dm.o: module_comm_dm_0.o module_comm_dm_1.o module_comm_dm_2.o module_comm_dm_3.o module_comm_dm_4.o
-
-module_comm_dm_0.o: module_domain.o module_configure.o
-module_comm_dm_1.o: module_domain.o module_configure.o
-module_comm_dm_2.o: module_domain.o module_configure.o
-module_comm_dm_3.o: module_domain.o module_configure.o
-module_comm_dm_4.o: module_domain.o module_configure.o
-
-module_comm_nesting_dm.o: \
- module_domain.o \
- module_configure.o
-
-module_dm_stubs.F: module_domain.o
-
-module_domain.o: module_domain_type.o \
- module_alloc_space_0.o \
- module_alloc_space_1.o \
- module_alloc_space_2.o \
- module_alloc_space_3.o \
- module_alloc_space_4.o \
- module_alloc_space_5.o \
- module_alloc_space_6.o \
- module_alloc_space_7.o \
- module_alloc_space_8.o \
- module_alloc_space_9.o \
- module_driver_constants.o \
- module_configure.o \
- module_machine.o \
- module_state_description.o \
- module_wrf_error.o \
- $(ESMF_MOD_DEPENDENCE)
-
-module_domain_type.o : module_driver_constants.o module_streams.o $(ESMF_MOD_DEPENDENCE)
-
-module_alloc_space_0.o : module_domain_type.o module_configure.o
-module_alloc_space_1.o : module_domain_type.o module_configure.o
-module_alloc_space_2.o : module_domain_type.o module_configure.o
-module_alloc_space_3.o : module_domain_type.o module_configure.o
-module_alloc_space_4.o : module_domain_type.o module_configure.o
-module_alloc_space_5.o : module_domain_type.o module_configure.o
-module_alloc_space_6.o : module_domain_type.o module_configure.o
-module_alloc_space_7.o : module_domain_type.o module_configure.o
-module_alloc_space_8.o : module_domain_type.o module_configure.o
-module_alloc_space_9.o : module_domain_type.o module_configure.o
-
-module_streams.o : \
- module_state_description.o
-
-module_driver_constants.o: \
- module_state_description.o \
- module_wrf_error.o
-
-module_integrate.o: \
- module_domain.o \
- module_timing.o \
- module_driver_constants.o \
- module_state_description.o \
- module_nesting.o \
- module_configure.o \
- $(LLIST) \
- module_cpl.o \
- module_dm.o \
- $(ESMF_MOD_DEPENDENCE)
-
-module_intermediate_nmm.o: \
- module_state_description.o \
- module_domain.o \
- module_configure.o \
- module_dm.o \
- module_comm_dm.o \
- module_timing.o
-
-module_io.o : md_calls.inc \
- module_dm.o \
- module_state_description.o \
- module_configure.o \
- module_streams.o \
- module_driver_constants.o
-
-module_io_quilt.o: \
- module_state_description.o \
- module_dm.o \
- module_configure.o \
- module_internal_header_util.o \
- module_quilt_outbuf_ops.o \
- module_wrf_error.o \
- module_cpl.o
-
-module_machine.o: \
- module_driver_constants.o
-
-module_nesting.o: \
- module_machine.o \
- module_driver_constants.o \
- module_configure.o \
- $(ESMF_MOD_DEPENDENCE) \
- module_domain.o
-
-module_quilt_outbuf_ops.o: \
- module_state_description.o module_timing.o
-
-module_tiles.o: module_domain.o \
- module_driver_constants.o \
- module_machine.o \
- module_configure.o \
- module_wrf_error.o
-
-module_timing.o: \
- module_state_description.o \
- module_wrf_error.o
-
-module_wrf_error.o: \
- wrf_shutdown.o \
- clog.o \
- $(ESMF_MOD_DEPENDENCE)
-
-wrf_debug.o: \
- module_wrf_error.o
-
-module_sm.o: module_wrf_error.o
-
-module_cpl.o: \
- ../share/module_model_constants.o \
- module_driver_constants.o \
- module_domain.o \
- module_configure.o \
- module_cpl_oasis3.o
-
-module_cpl_oasis3.o: module_driver_constants.o \
- module_domain.o
-
-module_clear_halos.o: module_configure.o \
- module_domain.o
-
-# End of DEPENDENCIES for frame
-
-# DEPENDENCIES for phys
-
-module_madwrf.o: ../share/module_model_constants.o \
- ../share/module_soil_pre.o \
- ../phys/module_mp_thompson.o
-
-module_bl_myjpbl.o: ../share/module_model_constants.o
-
-module_bl_myjurb.o: ../share/module_model_constants.o
-
-module_bl_gbmpbl.o: ../share/module_model_constants.o
-
-module_bl_boulac.o: ../share/module_model_constants.o
-
-module_bl_qnsepbl.o: ../share/module_model_constants.o
-
-module_progtm.o: module_gfs_machine.o
-
-module_bl_gfs.o: module_gfs_machine.o \
- module_gfs_physcons.o
-
-module_bl_gfsedmf.o: module_gfs_machine.o \
- module_gfs_physcons.o
-
-module_bl_mynn.o: ../share/module_model_constants.o
-
-module_cam_upper_bc.o: module_cam_shr_kind_mod.o \
- module_cam_support.o
-
-module_cam_constituents.o: module_cam_shr_kind_mod.o \
- module_cam_physconst.o \
- module_cam_support.o \
- ../frame/module_wrf_error.o
-
-module_cam_trb_mtn_stress.o: module_cam_shr_kind_mod.o \
- module_cam_support.o
-
-module_cam_molec_diff.o: module_cam_support.o \
- module_cam_constituents.o \
- module_cam_upper_bc.o
-
-module_data_cam_mam_aero.o : module_cam_shr_kind_mod.o \
- module_cam_support.o \
- module_cam_mp_radconstants.o
-
-module_data_cam_mam_asect.o : module_cam_shr_kind_mod.o \
- module_data_cam_mam_aero.o
-
-module_cam_bl_diffusion_solver.o: module_cam_support.o
-
-module_cam_bl_eddy_diff.o:module_cam_bl_diffusion_solver.o \
- module_cam_support.o
-
-module_bl_camuwpbl_driver.o: module_cam_shr_kind_mod.o \
- module_cam_support.o \
- module_cam_constituents.o \
- module_cam_bl_diffusion_solver.o\
- module_cam_physconst.o \
- module_cam_trb_mtn_stress.o \
- module_cam_bl_eddy_diff.o \
- module_cam_wv_saturation.o \
- module_cam_molec_diff.o \
- module_data_cam_mam_aero.o \
- ../share/module_model_constants.o \
- module_cam_esinti.o
-
-module_sf_mynn.o: module_sf_sfclay.o module_bl_mynn.o \
- ../share/module_model_constants.o \
- ../frame/module_wrf_error.o
-
-module_sf_fogdes.o: ../share/module_model_constants.o \
- module_bl_mynn.o
-
-module_bl_fogdes.o: ../share/module_model_constants.o \
- module_bl_mynn.o
-
-module_sf_gfdl.o : \
- module_gfs_machine.o \
- module_sf_exchcoef.o \
- module_gfs_funcphys.o \
- module_gfs_physcons.o
-
-module_cu_bmj.o: ../share/module_model_constants.o
-
-module_shcu_camuwshcu_driver.o: module_cam_support.o \
- module_mp_cammgmp_driver.o \
- module_cam_physconst.o \
- module_cam_wv_saturation.o \
- module_shcu_camuwshcu.o
-
-module_shcu_camuwshcu.o: module_cam_support.o \
- module_cam_constituents.o \
- module_cam_error_function.o \
- module_cam_esinti.o \
- module_cam_physconst.o \
- module_bl_camuwpbl_driver.o
-
-module_shcu_deng.o:
-
-module_cu_camzm_driver.o: ../share/module_model_constants.o \
- module_cam_shr_kind_mod.o \
- module_cam_support.o \
- module_cam_physconst.o \
- module_mp_cammgmp_driver.o \
- module_bl_camuwpbl_driver.o \
- module_cu_camzm.o
-
-module_cu_camzm.o: module_cam_shr_kind_mod.o \
- module_cam_constituents.o \
- module_cam_support.o \
- module_cam_physconst.o \
- module_cam_wv_saturation.o \
- module_cam_cldwat.o
-
-module_cam_error_function.o:
-
-module_cam_cldwat.o: module_cam_shr_kind_mod.o \
- module_cam_support.o \
- module_cam_wv_saturation.o \
- module_cam_physconst.o
-
-module_cam_esinti.o: module_cam_shr_kind_mod.o \
- module_cam_wv_saturation.o
-
-module_cam_wv_saturation.o: module_cam_shr_kind_mod.o \
- module_cam_support.o \
- module_cam_gffgch.o
-
-module_cam_gffgch.o: module_cam_shr_kind_mod.o \
- module_cam_support.o \
- module_cam_physconst.o
-
-module_cam_physconst.o: module_cam_shr_kind_mod.o \
- module_cam_shr_const_mod.o
-
-module_cam_shr_const_mod.o: module_cam_shr_kind_mod.o
-
-module_cam_support.o: module_cam_shr_kind_mod.o \
- ../frame/module_state_description.o
-
-module_cam_shr_kind_mod.o:
-
-module_cu_kf.o: ../frame/module_wrf_error.o
-
-
-module_cu_kfcup.o: ../frame/module_wrf_error.o \
- ../frame/module_state_description.o \
- $(CF2) \
- ../share/module_model_constants.o \
- module_mixactivate.o
-
-module_cu_kfeta.o: ../frame/module_wrf_error.o
-
-module_cu_gd.o:
-
-module_cu_ksas.o:
-
-module_cu_nsas.o:
-
-module_cu_du.o: ../frame/module_wrf_error.o
-
-module_gfs_physcons.o: module_gfs_machine.o
-
-module_gfs_funcphys.o: module_gfs_machine.o \
- module_gfs_physcons.o
-
-module_cu_sas.o: module_gfs_machine.o \
- module_gfs_funcphys.o \
- module_gfs_physcons.o
-module_cu_scalesas.o: module_gfs_machine.o \
- module_gfs_funcphys.o \
- module_gfs_physcons.o
-
-module_cu_osas.o: module_gfs_machine.o \
- module_gfs_funcphys.o \
- module_gfs_physcons.o
-
-module_cu_tiedtke.o:module_gfs_machine.o \
- module_gfs_funcphys.o \
- module_gfs_physcons.o
-
-module_cu_ntiedtke.o: ../share/module_model_constants.o
-
-module_ra_gfdleta.o: ../frame/module_dm.o \
- module_mp_etanew.o
-
-module_ra_HWRF.o: ../frame/module_dm.o module_mp_HWRF.o
-
-module_ra_rrtm.o: ../frame/module_wrf_error.o \
- module_ra_clWRF_support.o \
- ../frame/module_dm.o
-
-module_ra_cam_support.o: module_cam_support.o \
- ../frame/module_wrf_error.o
-
-module_ra_cam.o: module_ra_cam_support.o \
- module_cam_support.o \
- module_ra_clWRF_support.o \
- ../frame/module_wrf_error.o
-
-module_mp_lin.o : ../frame/module_wrf_error.o \
- module_mp_radar.o
-
-module_ra_flg.o: ../frame/module_wrf_error.o \
- ../frame/module_dm.o
-
-module_mp_sbu_ylin.o : ../frame/module_wrf_error.o \
- ../share/module_model_constants.o
-
-module_mp_milbrandt2mom.o : ../frame/module_wrf_error.o \
- ../share/module_model_constants.o
-
-module_mp_thompson.o : ../frame/module_wrf_error.o \
- module_mp_radar.o
-
-module_mp_nssl_2mom.o : ../frame/module_wrf_error.o \
- ../share/module_model_constants.o
-
-module_mp_fast_sbm.o : module_mp_radar.o
-
-module_mp_full_sbm.o : module_mp_radar.o
-
-module_mp_cammgmp_driver.o : module_cam_mp_microp_aero.o \
- module_cam_constituents.o \
- module_cam_shr_kind_mod.o \
- module_cam_cldwat.o \
- module_cam_mp_cldwat2m_micro.o \
- module_cam_physconst.o \
- module_cam_support.o \
- module_data_cam_mam_aero.o \
- module_data_cam_mam_asect.o \
- module_cam_wv_saturation.o \
- module_cam_mp_ndrop.o \
- module_cam_mp_conv_water.o \
- ../frame/module_state_description.o
-
-module_cam_mp_microp_aero.o : module_cam_shr_kind_mod.o \
- module_cam_support.o \
- module_cam_physconst.o \
- module_cam_error_function.o \
- module_cam_wv_saturation.o \
- module_cam_mp_ndrop.o \
- module_data_cam_mam_aero.o
-module_cam_mp_cldwat2m_micro.o : module_cam_shr_kind_mod.o \
- module_cam_support.o \
- module_cam_physconst.o \
- module_cam_error_function.o \
- module_cam_wv_saturation.o
-
-module_cam_mp_ndrop.o : module_cam_shr_kind_mod.o \
- module_data_cam_mam_aero.o \
- module_cam_support.o \
- module_cam_physconst.o \
- module_cam_constituents.o \
- module_cam_error_function.o \
- module_cam_wv_saturation.o
-
-module_cam_mp_modal_aero_initialize_data_phys.o : module_data_cam_mam_aero.o
-module_cam_mp_conv_water.o: module_cam_shr_kind_mod.o \
- module_cam_support.o \
- module_cam_physconst.o
-
-module_cam_mp_qneg3.o: module_cam_shr_kind_mod.o \
- module_cam_support.o
-
-module_cam_mp_radconstants.o : module_cam_shr_kind_mod.o \
- module_cam_support.o
-module_cam_infnan.o: module_cam_shr_kind_mod.o
-
-module_mp_gsfcgce.o : ../frame/module_wrf_error.o \
- module_mp_radar.o
-
-module_sf_myjsfc.o: ../share/module_model_constants.o
-
-module_sf_qnsesfc.o: ../share/module_model_constants.o
-
-module_sf_gfs.o: module_gfs_machine.o \
- module_gfs_funcphys.o \
- module_gfs_physcons.o \
- module_progtm.o
-
-module_sf_noahdrv.o: module_sf_noahlsm.o \
- module_sf_noahlsm_glacial_only.o \
- module_data_gocart_dust.o \
- module_sf_urban.o module_sf_bep.o module_sf_bep_bem.o
-
-module_sf_noahlsm.o: ../share/module_model_constants.o
-
-module_sf_clm.o: module_cam_shr_kind_mod.o \
- module_cam_shr_const_mod.o \
- module_cam_support.o \
- module_sf_urban.o \
- module_sf_noahlsm.o \
- module_ra_gfdleta.o \
- ../share/module_date_time.o \
- ../frame/module_wrf_error.o \
- ../frame/module_configure.o
-
-module_sf_ctsm.o: ../frame/module_dm.o \
- ../frame/module_configure.o \
- ../frame/module_wrf_error.o
-
-module_sf_ssib.o: ../share/module_model_constants.o
-
-module_sf_noah_seaice_drv.o: module_sf_noah_seaice.o
-
-module_sf_noah_seaice.o: module_sf_noahlsm.o ../share/module_model_constants.o
-
-module_sf_noahmpdrv.o: module_sf_noahmplsm.o \
- module_data_gocart_dust.o \
- module_sf_noahmp_glacier.o \
- module_sf_noahmp_groundwater.o \
- module_sf_gecros.o \
- ../share/module_model_constants.o \
- module_sf_urban.o module_sf_bep.o module_sf_bep_bem.o
-
-module_sf_noahlsm_glacial_only.o: module_sf_noahlsm.o module_sf_noahmplsm.o
-
-module_sf_noahmplsm.o: ../share/module_model_constants.o \
- module_sf_gecros.o \
- module_sf_myjsfc.o
-
-module_sf_noahmp_groundwater.o: module_sf_noahmplsm.o
-
-module_sf_bep.o: ../share/module_model_constants.o module_sf_urban.o module_bep_bem_helper.o
-
-module_sf_bep_bem.o: ../share/module_model_constants.o module_sf_bem.o module_sf_urban.o module_bep_bem_helper.o
-
-module_sf_bem.o: ../share/module_model_constants.o
-
-module_sf_ruclsm.o: ../frame/module_wrf_error.o module_data_gocart_dust.o
-
-module_sf_pxlsm.o: ../share/module_model_constants.o module_sf_pxlsm_data.o
-
-module_twoway_ra_rrtmg_sw.o: module_twoway_rrtmg_aero_optical_util.o
-
-module_ra_rrtmg_sw.o: module_ra_rrtmg_lw.o
-module_ra_rrtmg_swf.o: module_ra_rrtmg_lwf.o
-module_ra_rrtmg_swk.o: module_ra_rrtmg_lwk.o module_ra_effective_radius.o
-
-module_ra_rrtmg_lw.o: ../share/module_model_constants.o \
- module_ra_clWRF_support.o
-module_ra_rrtmg_lwf.o: ../share/module_model_constants.o \
- module_ra_clWRF_support.o
-module_ra_rrtmg_lwk.o: ../share/module_model_constants.o \
- module_ra_clWRF_support.o
-
-
-
-module_physics_addtendc.o: \
- module_cu_kf.o \
- module_cu_kfeta.o \
- $(PHYS_CU) \
- ../frame/module_state_description.o \
- ../frame/module_configure.o
-
-module_physics_init.o : \
- module_ra_rrtm.o \
- module_ra_rrtmg_lwf.o \
- module_ra_rrtmg_swf.o \
- module_ra_rrtmg_lw.o \
- module_ra_rrtmg_sw.o \
- module_ra_rrtmg_lwk.o \
- module_ra_rrtmg_swk.o \
- module_ra_cam.o \
- $(PHYS_CU) $(PHYS_BL) \
- module_ra_cam_support.o \
- module_ra_sw.o \
- module_ra_gsfcsw.o \
- module_ra_gfdleta.o \
- module_ra_HWRF.o \
- module_ra_hs.o \
- module_ra_flg.o \
- module_sf_sfclay.o \
- module_sf_sfclayrev.o \
- module_sf_slab.o \
- module_sf_myjsfc.o \
- module_sf_mynn.o \
- module_sf_fogdes.o \
- module_sf_urban.o \
- module_sf_qnsesfc.o \
- module_sf_pxsfclay.o \
- module_sf_noahlsm.o \
- module_sf_noahdrv.o \
- module_sf_clm.o \
- module_sf_ctsm.o \
- module_sf_ssib.o \
- module_sf_noahmplsm.o \
- module_sf_noahmpdrv.o \
- module_sf_bep.o \
- module_sf_bep_bem.o \
- module_sf_ruclsm.o \
- module_sf_pxlsm.o \
- module_sf_lake.o \
- module_bl_ysu.o \
- module_bl_mrf.o \
- module_bl_gfs.o \
- module_bl_gfsedmf.o \
- module_bl_acm.o \
- module_bl_myjpbl.o \
- module_bl_qnsepbl.o \
- module_bl_mynn.o \
- module_bl_myjurb.o \
- module_bl_boulac.o \
- module_bl_camuwpbl_driver.o \
- module_bl_temf.o \
- module_bl_mfshconvpbl.o \
- module_cu_kf.o \
- module_cu_g3.o \
- module_cu_kfeta.o \
- module_cu_mskf.o \
- module_cu_bmj.o \
- module_cu_gd.o \
- module_cu_ksas.o \
- module_cu_nsas.o \
- module_cu_sas.o \
- module_cu_scalesas.o \
- module_cu_osas.o \
- module_cu_camzm_driver.o \
- module_cu_kfcup.o \
- module_shcu_camuwshcu.o \
- module_shcu_deng.o \
- module_shcu_grims.o \
- module_mp_sbu_ylin.o \
- module_mp_wsm3.o \
- module_mp_wsm5.o \
- module_mp_wsm6.o \
- module_mp_etanew.o \
- module_mp_fer_hires.o \
- module_mp_HWRF.o \
- module_mp_fast_sbm.o \
- module_fdda_psufddagd.o \
- module_fdda_spnudging.o \
- module_fddaobs_rtfdda.o \
- module_mp_thompson.o \
- module_mp_gsfcgce.o \
- module_mp_gsfcgce_4ice_nuwrf.o \
- module_mp_morr_two_moment.o \
- module_mp_milbrandt2mom.o \
- module_mp_nssl_2mom.o \
- module_mp_wdm5.o \
- module_mp_wdm6.o \
- module_cam_physconst.o \
- module_cam_shr_kind_mod.o \
- module_mp_cammgmp_driver.o \
- module_cam_esinti.o \
- module_cam_constituents.o \
- module_cam_mp_modal_aero_initialize_data_phys.o \
- module_cam_support.o \
- module_wind_fitch.o \
- module_gocart_coupling.o \
- module_data_gocart_dust.o \
- ../frame/module_state_description.o \
- ../frame/module_configure.o \
- ../frame/module_wrf_error.o \
- ../frame/module_dm.o \
- ../share/module_llxy.o \
- ../share/module_model_constants.o
-
-module_microphysics_driver.o: \
- module_mixactivate.o \
- module_mp_kessler.o module_mp_sbu_ylin.o module_mp_lin.o \
- $(PHYS_MP) \
- module_mp_wsm3.o module_mp_wsm5.o \
- module_mp_wsm6.o module_mp_etanew.o \
- module_mp_fer_hires.o module_mp_HWRF.o \
- module_mp_thompson.o \
- module_mp_gsfcgce.o \
- module_mp_gsfcgce_4ice_nuwrf.o \
- module_mp_morr_two_moment.o \
- module_mp_morr_two_moment_aero.o \
- module_mp_milbrandt2mom.o \
- module_mp_nssl_2mom.o \
- module_mp_wdm5.o module_mp_wdm6.o \
- module_mp_cammgmp_driver.o \
- module_irrigation.o \
- module_mp_fast_sbm.o \
- ../frame/module_driver_constants.o \
- ../frame/module_state_description.o \
- ../frame/module_wrf_error.o \
- ../frame/module_configure.o \
- ../frame/module_comm_dm.o \
- ../frame/module_dm.o \
- ../share/module_model_constants.o
-
-module_shallowcu_driver.o: \
- module_shcu_camuwshcu_driver.o \
- module_shcu_deng.o \
- ../frame/module_state_description.o \
- ../share/module_model_constants.o
-
-module_cu_gf_wrfdrv.o: \
- module_cu_gf_deep.o \
- module_cu_gf_sh.o
-module_cu_gf_sh.o: \
- module_cu_gf_deep.o
-module_cumulus_driver.o: \
- module_cu_kf.o \
- module_cu_g3.o \
- module_cu_gf_wrfdrv.o \
- module_cu_kfeta.o \
- $(PHYS_CU) \
- module_cu_bmj.o \
- module_cu_gd.o \
- module_cu_ksas.o \
- module_cu_nsas.o \
- module_cu_sas.o \
- module_cu_scalesas.o \
- module_cu_osas.o \
- module_cu_camzm_driver.o \
- module_cu_tiedtke.o \
- module_cu_ntiedtke.o \
- module_cu_mskf.o \
- module_cu_kfcup.o \
- ../frame/module_state_description.o \
- ../frame/module_configure.o \
- ../frame/module_domain.o \
- ../frame/module_dm.o \
- ../frame/module_comm_dm.o \
- ../frame/module_wrf_error.o \
- ../share/module_model_constants.o
-
-module_pbl_driver.o: \
- module_bl_myjpbl.o \
- module_bl_myjurb.o \
- module_bl_qnsepbl.o \
- module_bl_acm.o \
- module_bl_ysu.o \
- module_bl_mrf.o \
- module_bl_boulac.o \
- module_bl_camuwpbl_driver.o \
- module_bl_gfs.o \
- module_bl_gfsedmf.o \
- module_bl_mynn.o \
- module_bl_fogdes.o \
- module_bl_gwdo.o \
- module_bl_gwdo_gsl.o \
- module_bl_temf.o \
- module_bl_mfshconvpbl.o \
- $(PHYS_BL) \
- module_wind_fitch.o \
- ../frame/module_state_description.o \
- ../frame/module_configure.o \
- ../share/module_model_constants.o
-
-module_data_gocart_dust.o:
-
-module_mixactivate.o: \
- module_radiation_driver.o
-
-module_radiation_driver.o: \
- module_ra_sw.o \
- module_ra_gsfcsw.o \
- module_ra_rrtm.o \
- module_ra_rrtmg_lw.o \
- module_ra_rrtmg_sw.o \
- module_twoway_ra_rrtmg_sw.o \
- module_ra_rrtmg_lwf.o \
- module_ra_rrtmg_swf.o \
- module_ra_rrtmg_lwk.o \
- module_ra_rrtmg_swk.o \
- module_ra_cam.o \
- module_ra_farms.o \
- module_ra_gfdleta.o \
- module_ra_HWRF.o \
- module_ra_hs.o \
- module_ra_goddard.o \
- module_ra_flg.o \
- module_ra_aerosol.o \
- module_mp_thompson.o \
- ../frame/module_driver_constants.o \
- ../frame/module_state_description.o \
- ../frame/module_dm.o \
- ../frame/module_comm_dm.o \
- ../frame/module_domain.o \
- ../frame/module_wrf_error.o \
- ../frame/module_configure.o \
- ../share/module_bc.o \
- ../share/module_model_constants.o
-
-module_surface_driver.o: \
- module_sf_sfclay.o \
- module_sf_sfclayrev.o \
- module_sf_slab.o \
- module_sf_myjsfc.o \
- module_sf_qnsesfc.o \
- module_sf_pxsfclay.o \
- module_sf_gfs.o \
- module_sf_noah_seaice_drv.o \
- module_sf_noahmp_groundwater.o \
- module_sf_noahdrv.o \
- module_sf_clm.o \
- module_sf_ctsm.o \
- module_sf_ssib.o \
- module_sf_noahmpdrv.o \
- module_sf_ruclsm.o \
- module_sf_pxlsm.o \
- module_sf_mynn.o \
- module_sf_fogdes.o \
- module_sf_sfcdiags.o \
- module_sf_sfcdiags_ruclsm.o \
- module_sf_sstskin.o \
- module_sf_lake.o \
- module_sf_tmnupdate.o \
- module_sf_temfsfclay.o \
- module_sf_idealscmsfclay.o \
- module_sf_scmflux.o \
- module_sf_scmskintemp.o \
- module_sf_ocean_driver.o \
- module_irrigation.o \
- ../frame/module_state_description.o \
- ../frame/module_configure.o \
- ../frame/module_cpl.o \
- ../share/module_model_constants.o
-
-module_sf_ocean_driver.o : \
- module_sf_oml.o \
- module_sf_3dpwp.o \
- ../frame/module_state_description.o
-
-module_diagnostics_driver.o: \
- module_lightning_driver.o \
- module_diag_misc.o \
- module_diag_nwp.o \
- module_diag_cl.o \
- module_diag_pld.o \
- module_diag_zld.o \
- module_diag_afwa.o \
- module_diag_hailcast.o \
- module_diag_rasm.o \
- module_diag_trad_fields.o \
- module_diag_solar.o \
- ../frame/module_comm_dm.o \
- ../frame/module_state_description.o \
- ../frame/module_domain.o \
- ../frame/module_configure.o \
- ../frame/module_driver_constants.o \
- ../share/module_model_constants.o
-
-module_diag_misc.o: \
- ../frame/module_dm.o
-
-module_diag_cl.o: \
- ../frame/module_dm.o \
- ../frame/module_configure.o
-
-module_diag_pld.o: \
- ../share/module_model_constants.o
-
-module_diag_zld.o: \
- ../share/module_model_constants.o
-
-module_diag_afwa.o: \
- module_diag_trad_fields.o \
- ../frame/module_domain.o \
- ../frame/module_dm.o \
- ../frame/module_state_description.o \
- ../frame/module_configure.o \
- ../frame/module_streams.o \
- ../external/esmf_time_f90/module_utility.o \
- ../share/module_model_constants.o
-
-module_diag_hailcast.o: \
- ../frame/module_configure.o \
- ../frame/module_domain.o \
- ../frame/module_dm.o \
- ../frame/module_state_description.o \
- ../frame/module_streams.o \
- ../external/esmf_time_f90/module_utility.o \
- ../share/module_model_constants.o
-
-module_diag_rasm.o: \
- module_cam_shr_const_mod.o
-
-module_diag_trad_fields.o: \
- module_diag_functions.o \
- ../share/module_model_constants.o
-
-module_diag_solar.o: \
- ../share/module_model_constants.o
-
-module_diag_refl.o: \
- ../frame/module_dm.o \
- ../share/module_model_constants.o
-
-module_mixactivate.o: \
- module_radiation_driver.o
-
-module_fddagd_driver.o: \
- module_fdda_spnudging.o \
- module_fdda_psufddagd.o \
- ../frame/module_state_description.o \
- ../frame/module_configure.o \
- ../share/module_model_constants.o
-
-module_fddaobs_driver.o: \
- ../frame/module_domain.o \
- ../share/module_bc.o \
- ../share/module_model_constants.o \
- module_fddaobs_rtfdda.o
-
-module_sf_lake.o : \
- ../share/module_model_constants.o
-
-
-module_fr_fire_driver.o: \
- ../share/module_model_constants.o \
- ../frame/module_comm_dm.o \
- ../frame/module_domain.o \
- ../frame/module_configure.o \
- ../frame/module_dm.o \
- module_fr_fire_phys.o \
- module_fr_fire_model.o \
- module_fr_fire_util.o \
- module_fr_fire_core.o \
- module_fr_fire_atm.o
-
-module_fr_fire_driver_wrf.o: \
- ../share/module_model_constants.o \
- ../frame/module_comm_dm.o \
- module_fr_fire_driver.o \
- module_fr_fire_atm.o \
- module_fr_fire_util.o
-
-module_fr_fire_atm.o: \
- ../share/module_model_constants.o \
- module_fr_fire_util.o
-
-module_fr_fire_model.o: \
- module_fr_fire_core.o \
- module_fr_fire_phys.o \
- module_fr_fire_util.o
-
-module_fr_fire_core.o: \
- module_fr_fire_util.o \
- module_fr_fire_phys.o
-
-module_fr_fire_phys.o: \
- ../share/module_model_constants.o \
- module_fr_fire_util.o
-
-module_fire_debug_output.o: \
- ../frame/module_domain.o \
- ../frame/module_configure.o \
- ../share/mediation_integrate.o
-
-module_fdda_spnudging.o :\
- ../frame/module_dm.o \
- ../frame/module_state_description.o \
- ../frame/module_domain.o \
- ../frame/module_wrf_error.o
-
-module_sf_bep.o :\
- module_sf_urban.o
-
-module_mp_wsm5.o :\
- module_mp_wsm5_accel.F \
- module_mp_radar.o
-
-module_mp_wdm5.o :\
- module_mp_radar.o
-
-module_mp_wsm6.o :\
- module_mp_radar.o
-
-module_mp_wdm6.o :\
- module_mp_radar.o
-
-module_mp_morr_two_moment.o :\
- module_mp_radar.o
-
-module_mp_wsm3.o :\
- module_mp_wsm3_accel.F
-
-module_mp_radar.o :
-
-module_lightning_driver.o : \
- module_ltng_crmpr92.o module_ltng_cpmpr92z.o module_ltng_iccg.o
-
-module_ltng_cpmpr92z.o :
-
-module_ltng_crmpr92.o :
-
-module_ltng_iccg.o :
-
-module_ra_aerosol.o :\
- ../frame/module_wrf_error.o
-
-module_gocart_coupling.o:
-
-module_ra_goddard.o : ../frame/module_wrf_error.o \
- module_gocart_coupling.o \
- module_checkerror.o
-
-module_mp_gsfcgce_4ice_nuwrf.o : ../frame/module_wrf_error.o \
- module_gocart_coupling.o \
- module_checkerror.o \
- module_mp_radar.o
-
-# End of DEPENDENCIES for phys
-
-
-# DEPENDENCIES for share
-
-module_trajectory.o: ../frame/module_domain.o \
- ../frame/module_configure.o \
- ../frame/module_dm.o \
- ../frame/module_comm_dm.o \
- ../frame/module_state_description.o \
- module_model_constants.o \
- module_date_time.o \
- module_llxy.o
-
-solve_interface.o: solve_em.int ../frame/module_domain.o ../frame/module_configure.o \
- ../frame/module_timing.o ../frame/module_driver_constants.o \
- ../frame/module_wrf_error.o \
- ../frame/module_state_description.o ../phys/module_checkerror.o \
- ../frame/module_wrf_error.o module_trajectory.o
-
-start_domain.o: start_domain_em.int wrf_timeseries.o track_driver.o ../frame/module_domain.o ../frame/module_configure.o ../share/module_llxy.o
-
-module_date_time.o: ../frame/module_wrf_error.o ../frame/module_configure.o \
- module_model_constants.o
-
-module_bc.o: ../frame/module_configure.o ../frame/module_state_description.o \
- ../frame/module_wrf_error.o module_model_constants.o
-
-module_bc_time_utilities.o: $(ESMF_MOD_DEPENDENCE)
-
-module_get_file_names.o: ../frame/module_dm.o
-
-module_io_wrf.o: module_date_time.o \
- ../frame/module_wrf_error.o ../frame/module_streams.o \
- $(ESMF_MOD_DEPENDENCE)
-
-module_io_domain.o: module_io_wrf.o module_date_time.o ../frame/module_io.o \
- ../frame/module_domain.o ../frame/module_configure.o \
- ../frame/module_state_description.o
-
-output_wrf.o: ../frame/module_io.o ../frame/module_wrf_error.o \
- ../frame/module_domain.o ../frame/module_state_description.o \
- ../frame/module_configure.o module_io_wrf.o \
- $(ESMF_MOD_DEPENDENCE)
-
-wrf_fddaobs_in.o: \
- module_date_time.o \
- module_llxy.o
-
-wrf_timeseries.o: wrf_tsin.o \
- module_model_constants.o \
- module_llxy.o \
- module_model_constants.o \
- module_string_tools.o \
- ../frame/module_domain.o \
- ../frame/module_configure.o \
- ../frame/module_dm.o
-
-track_driver.o: track_input.o \
- module_model_constants.o \
- module_llxy.o \
- module_date_time.o \
- ../frame/module_domain.o \
- ../frame/module_configure.o \
- ../frame/module_state_description.o \
- ../frame/module_dm.o
-
-input_wrf.o: ../frame/module_io.o ../frame/module_wrf_error.o \
- ../frame/module_domain.o ../frame/module_state_description.o \
- ../frame/module_configure.o module_io_wrf.o \
- $(ESMF_MOD_DEPENDENCE)
-
-wrf_ext_write_field.o : ../frame/module_io.o ../frame/module_wrf_error.o \
- ../frame/module_domain.o ../frame/module_timing.o
-
-wrf_ext_read_field.o : ../frame/module_io.o ../frame/module_wrf_error.o \
- ../frame/module_domain.o ../frame/module_timing.o
-
-module_soil_pre.o: module_date_time.o ../frame/module_state_description.o
-
-module_check_a_mundo.o: ../frame/module_configure.o ../frame/module_wrf_error.o \
- ../frame/module_state_description.o \
- ../share/module_model_constants.o \
- ../phys/module_bep_bem_helper.o
-
-dfi.o : ../frame/module_wrf_error.o ../frame/module_configure.o \
- ../frame/module_state_description.o \
- ../frame/module_domain.o ../frame/module_timing.o \
- ../frame/module_machine.o ../frame/module_comm_dm.o \
- ../frame/module_dm.o ../frame/module_driver_constants.o \
- module_model_constants.o module_date_time.o module_io_domain.o \
- $(ESMF_MOD_DEPENDENCE)
-
-module_optional_input.o: module_io_wrf.o module_io_domain.o \
- ../frame/module_domain.o ../frame/module_configure.o
-
-mediation_wrfmain.o: ../frame/module_domain.o ../frame/module_configure.o ../frame/module_dm.o \
- ../frame/module_timing.o $(ESMF_MOD_DEPENDENCE) \
- module_bc_time_utilities.o module_io_domain.o
-
-init_modules.o: ../frame/module_configure.o ../frame/module_driver_constants.o \
- ../frame/module_domain.o ../frame/module_machine.o \
- ../frame/module_nesting.o ../frame/module_timing.o \
- ../frame/module_tiles.o ../frame/module_io.o \
- ../frame/module_io_quilt.o ../frame/module_dm.o \
- ../external/io_int/io_int.o \
- module_io_wrf.o module_bc.o module_model_constants.o \
- ../frame/module_wrf_error.o
-
-interp_fcn.o: ../frame/module_timing.o ../frame/module_state_description.o ../frame/module_configure.o \
- ../frame/module_wrf_error.o module_model_constants.o module_interp_nmm.o module_interp_store.o
-
-module_interp_nmm.o: module_model_constants.o module_interp_store.o
-
-mediation_feedback_domain.o: ../frame/module_domain.o ../frame/module_configure.o \
- ../frame/module_intermediate_nmm.o
-
-mediation_force_domain.o: ../frame/module_domain.o ../frame/module_configure.o
-
-mediation_integrate.o: ../frame/module_domain.o ../frame/module_configure.o \
- ../frame/module_timing.o \
- $(ESMF_MOD_DEPENDENCE) \
- module_date_time.o module_bc_time_utilities.o \
- module_compute_geop.o \
- $(PERTMOD) \
- module_io_domain.o
-
-
-mediation_interp_domain.o: ../frame/module_domain.o ../frame/module_configure.o \
- ../frame/module_timing.o
-
-mediation_nest_move.o: \
- ../frame/module_domain.o \
- ../frame/module_configure.o \
- ../frame/module_state_description.o \
- ../frame/module_driver_constants.o \
- module_io_domain.o
-
-#mediation_conv_emissions.o: ../frame/module_domain.o ../frame/module_configure.o \
-# ../external/esmf_time_f90/ESMF_Mod.o \
-# module_date_time.o module_bc_time_utilities.o \
-# module_io_domain.o
-
-set_timekeeping.o: ../frame/module_domain.o ../frame/module_configure.o \
- $(ESMF_MOD_DEPENDENCE)
-
-wrf_inputout.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxinput1out.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxinput2out.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxinput3out.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxinput4out.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxinput5out.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxinput6out.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxinput7out.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxinput8out.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxinput9out.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxinput10out.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxinput11out.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_histout.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxhist1out.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxhist2out.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxhist3out.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxhist4out.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxhist5out.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxhist6out.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxhist7out.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxhist8out.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxhist9out.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxhist10out.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxhist11out.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_restartout.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_bdyout.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_inputin.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxhist1in.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxhist2in.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxhist3in.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxhist4in.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxhist5in.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxhist6in.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxhist7in.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxhist8in.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxhist9in.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxhist10in.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxhist11in.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxinput1in.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxinput2in.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxinput3in.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxinput4in.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxinput5in.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxinput6in.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxinput7in.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxinput8in.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxinput9in.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxinput10in.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_auxinput11in.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_bdyin.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_histin.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_restartin.o : ../frame/module_domain.o \
- ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o
-wrf_tsin.o : ../frame/module_domain.o
-
-track_input.o : ../frame/module_domain.o
-
-module_random.o: bobrand.o
-
-# End of DEPENDENCIES for share
-
-
-# DEPENDENCIES for main
-
-convert_nmm.o: \
- ../frame/module_machine.o \
- ../frame/module_domain.o \
- ../frame/module_driver_constants.o \
- ../frame/module_configure.o \
- ../frame/module_timing.o \
- ../frame/module_dm.o \
- ../share/module_bc.o \
- ../share/module_io_domain.o \
- $(ESMF_MOD_DEPENDENCE)
-
-convert_em.o: \
- ../frame/module_machine.o \
- ../frame/module_domain.o \
- ../frame/module_driver_constants.o \
- ../frame/module_configure.o \
- ../frame/module_timing.o \
- ../frame/module_dm.o \
- ../share/module_bc.o \
- ../share/module_io_domain.o \
- $(ESMF_MOD_DEPENDENCE)
-
-ideal_em.o: \
- ../frame/module_machine.o \
- ../frame/module_domain.o \
- ../frame/module_driver_constants.o \
- ../frame/module_configure.o \
- ../frame/module_timing.o \
- ../frame/module_dm.o \
- ../share/module_io_domain.o \
- ../dyn_$(SOLVER)/$(CASE_MODULE) \
- $(ESMF_MOD_DEPENDENCE)
-
-ideal_nmm.o: \
- ../dyn_$(SOLVER)/$(CASE_MODULE) \
- ../share/module_optional_input.o \
- ../share/module_io_domain.o \
- ../share/input_wrf.o
-
-ndown_em.o: \
- ../frame/module_machine.o \
- ../frame/module_domain.o \
- ../frame/module_driver_constants.o \
- ../frame/module_configure.o \
- ../frame/module_timing.o \
- ../frame/module_dm.o \
- ../frame/module_wrf_error.o \
- ../frame/module_integrate.o \
- ../share/module_bc.o \
- ../share/module_io_domain.o \
- ../share/module_get_file_names.o \
- ../share/module_model_constants.o \
- ../share/module_soil_pre.o \
- ../dyn_em/module_initialize_$(IDEAL_CASE).o \
- ../dyn_em/module_big_step_utilities_em.o \
- ../dyn_em/nest_init_utils.o \
- $(ESMF_MOD_DEPENDENCE)
-
-# this already built above :../dyn_em/module_initialize.real.o \
-real_em.o: \
- ../frame/module_machine.o \
- ../frame/module_domain.o \
- ../frame/module_driver_constants.o \
- ../frame/module_configure.o \
- ../frame/module_timing.o \
- ../frame/module_dm.o \
- ../dyn_em/module_initialize_$(IDEAL_CASE).o \
- ../dyn_em/module_big_step_utilities_em.o \
- ../share/module_io_domain.o \
- ../share/module_date_time.o \
- ../share/module_optional_input.o \
- ../share/module_bc_time_utilities.o \
- ../dyn_em/module_wps_io_arw.o \
- $(ESMF_MOD_DEPENDENCE)
-# ../chem/module_input_chem_data.o \
-# ../chem/module_input_chem_bioemiss.o \
-
-
-tc_em.o: \
- ../frame/module_machine.o \
- ../frame/module_domain.o \
- ../frame/module_driver_constants.o \
- ../frame/module_configure.o \
- ../frame/module_timing.o \
- ../frame/module_dm.o \
- ../dyn_em/module_initialize_$(IDEAL_CASE).o \
- ../dyn_em/module_big_step_utilities_em.o \
- ../share/module_io_domain.o \
- ../share/module_date_time.o \
- ../share/module_optional_input.o \
- ../share/module_bc_time_utilities.o \
- $(ESMF_MOD_DEPENDENCE)
-
-
-
-wrf.o: ../main/module_wrf_top.o
-
-wrf_ESMFMod.o: ../main/module_wrf_top.o
-
-wrf_SST_ESMF.o: wrf_ESMFMod.o
-
-module_wrf_top.o: ../frame/module_machine.o \
- ../frame/module_domain.o \
- ../frame/module_integrate.o \
- ../frame/module_driver_constants.o \
- ../frame/module_configure.o \
- ../frame/module_timing.o \
- ../frame/module_wrf_error.o \
- ../frame/module_state_description.o \
- ../frame/module_cpl.o \
- $(ESMF_MOD_DEPENDENCE)
-
-# End of DEPENDENCIES for main
-
diff --git a/UTIL/wrfcmaq_twoway_coupler/phys/Makefile b/UTIL/wrfcmaq_twoway_coupler/phys/Makefile
deleted file mode 100644
index eddf501263..0000000000
--- a/UTIL/wrfcmaq_twoway_coupler/phys/Makefile
+++ /dev/null
@@ -1,264 +0,0 @@
-
-
-LN = ln -sf
-MAKE = make -i -r
-RM = rm -f
-
-
-MODULES = \
- complex_number_module.o \
- module_bep_bem_helper.o \
- module_cam_shr_kind_mod.o \
- module_twoway_rrtmg_aero_optical_util.o \
- module_cam_support.o \
- module_cam_shr_const_mod.o \
- module_cam_physconst.o \
- module_cam_cldwat.o \
- module_cam_wv_saturation.o \
- module_cam_esinti.o \
- module_cam_gffgch.o \
- module_cam_error_function.o \
- module_cam_constituents.o \
- module_cam_trb_mtn_stress.o \
- module_cam_molec_diff.o \
- module_cam_upper_bc.o \
- module_cam_bl_diffusion_solver.o \
- module_cam_bl_eddy_diff.o \
- module_cam_mp_microp_aero.o \
- module_cam_mp_cldwat2m_micro.o \
- module_cam_mp_ndrop.o \
- module_cam_mp_modal_aero_initialize_data_phys.o \
- module_cam_mp_radconstants.o \
- module_cam_mp_conv_water.o \
- module_cam_mp_qneg3.o \
- module_data_cam_mam_aero.o \
- module_data_cam_mam_asect.o \
- module_cam_infnan.o \
- $(PHYS_PLUS) \
- module_bl_ysu.o \
- module_bl_shinhong.o \
- module_bl_mrf.o \
- module_bl_gfs.o \
- module_bl_gfsedmf.o \
- module_bl_myjpbl.o \
- module_bl_qnsepbl.o \
- module_bl_acm.o \
- module_bl_mynn.o \
- module_bl_fogdes.o \
- module_bl_gwdo.o \
- module_bl_gwdo_gsl.o \
- module_bl_myjurb.o \
- module_bl_boulac.o \
- module_checkerror.o \
- module_bl_camuwpbl_driver.o \
- module_bl_mfshconvpbl.o \
- module_bl_eepsilon.o \
- module_shcu_camuwshcu_driver.o \
- module_shcu_camuwshcu.o \
- module_shcu_deng.o \
- module_shcu_grims.o \
- module_shcu_nscv.o \
- module_cu_camzm_driver.o \
- module_cu_camzm.o \
- module_bl_temf.o \
- module_bl_gbmpbl.o \
- module_cu_g3.o \
- module_cu_kf.o \
- module_cu_bmj.o \
- module_cu_kfeta.o \
- module_cu_mskf.o \
- module_cu_tiedtke.o\
- module_cu_ntiedtke.o\
- module_cu_gd.o \
- module_cu_gf_ctrans.o \
- module_cu_gf_wrfdrv.o \
- module_cu_gf_deep.o \
- module_cu_gf_sh.o \
- module_cu_ksas.o \
- module_cu_nsas.o \
- module_cu_sas.o \
- module_gocart_coupling.o \
- module_cu_scalesas.o \
- module_cu_osas.o \
- module_cu_kfcup.o \
- module_madwrf.o \
- module_mp_radar.o \
- module_mp_kessler.o \
- module_mp_lin.o \
- module_mp_sbu_ylin.o \
- module_mp_wsm3.o \
- module_mp_wsm5.o \
- module_mp_wsm6.o \
- module_mp_wsm7.o \
- module_mp_etanew.o \
- module_mp_fer_hires.o \
- module_mp_HWRF.o \
- module_mp_thompson.o \
- module_mp_SBM_polar_radar.o \
- module_mp_full_sbm.o \
- module_mp_fast_sbm.o \
- module_ltng_lpi.o \
- module_mp_gsfcgce.o \
- module_mp_gsfcgce_4ice_nuwrf.o \
- module_mp_morr_two_moment.o \
- module_mp_p3.o \
- module_mp_jensen_ishmael.o \
- module_mp_morr_two_moment_aero.o \
- module_mp_milbrandt2mom.o \
- module_mp_nssl_2mom.o \
- module_mp_wdm5.o \
- module_mp_wdm6.o \
- module_mp_wdm7.o \
- module_mp_ntu.o \
- module_mp_cammgmp_driver.o \
- module_ra_sw.o \
- module_ra_clWRF_support.o \
- module_ra_gsfcsw.o \
- module_ra_goddard.o \
- module_ra_effective_radius.o \
- module_ra_rrtm.o \
- module_ra_rrtmg_lw.o \
- module_ra_rrtmg_sw.o \
- module_ra_rrtmg_lwf.o \
- module_ra_rrtmg_swf.o \
- module_ra_rrtmg_lwk.o \
- module_ra_rrtmg_swk.o \
- module_ra_cam_support.o \
- module_ra_cam.o \
- module_ra_gfdleta.o \
- module_ra_flg.o \
- module_ra_HWRF.o \
- module_ra_hs.o \
- module_ra_eclipse.o \
- module_ra_aerosol.o \
- module_ra_farms.o \
- module_sf_sfclay.o \
- module_sf_sfclayrev.o \
- module_sf_gfs.o \
- module_sf_exchcoef.o \
- module_sf_gfdl.o \
- module_sf_slab.o \
- module_sf_noahdrv.o \
- module_sf_noahlsm.o \
- module_sf_clm.o \
- module_sf_ctsm.o \
- module_sf_ssib.o \
- module_sf_noah_seaice.o \
- module_sf_noah_seaice_drv.o \
- module_sf_noahlsm_glacial_only.o \
- module_sf_noahmp_groundwater.o \
- module_sf_gecros.o \
- module_sf_noahmpdrv.o \
- module_sf_noahmplsm.o \
- module_sf_noahmp_glacier.o \
- module_sf_urban.o \
- module_sf_bep.o \
- module_sf_bep_bem.o \
- module_sf_bem.o \
- module_sf_pxlsm.o \
- module_sf_pxlsm_data.o \
- module_sf_ruclsm.o \
- module_sf_sfcdiags.o \
- module_sf_sfcdiags_ruclsm.o \
- module_sf_sstskin.o \
- module_sf_tmnupdate.o \
- module_sf_ocean_driver.o \
- module_sf_oml.o \
- module_sf_3dpwp.o \
- module_sf_myjsfc.o \
- module_sf_qnsesfc.o \
- module_sf_mynn.o \
- module_sf_fogdes.o \
- module_sf_pxsfclay.o \
- module_sf_temfsfclay.o \
- module_sf_idealscmsfclay.o \
- module_sf_scmflux.o \
- module_sf_scmskintemp.o \
- module_physics_addtendc.o \
- module_physics_init.o \
- module_gfs_machine.o \
- module_gfs_funcphys.o \
- module_gfs_physcons.o \
- module_progtm.o \
- module_pbl_driver.o \
- module_data_gocart_dust.o \
- module_dust_emis.o \
- module_cumulus_driver.o \
- module_shallowcu_driver.o \
- module_microphysics_driver.o \
- module_microphysics_zero_out.o \
- module_mixactivate.o \
- module_radiation_driver.o \
- module_surface_driver.o \
- module_lightning_driver.o \
- module_ltng_cpmpr92z.o \
- module_ltng_crmpr92.o \
- module_ltng_iccg.o \
- module_fdda_psufddagd.o \
- module_fdda_spnudging.o \
- module_fddagd_driver.o \
- module_fddaobs_rtfdda.o \
- module_fddaobs_driver.o \
- module_wind_fitch.o \
- module_sf_lake.o \
- module_diagnostics_driver.o \
- module_irrigation.o
-
-FIRE_MODULES = \
- module_fr_fire_driver.o \
- module_fr_fire_driver_wrf.o \
- module_fr_fire_atm.o \
- module_fr_fire_model.o \
- module_fr_fire_core.o \
- module_fr_fire_phys.o \
- module_fr_fire_util.o
-
-DIAGNOSTIC_MODULES_EM = \
- module_diag_afwa.o \
- module_diag_cl.o \
- module_diag_functions.o \
- module_diag_hailcast.o \
- module_diag_misc.o \
- module_diag_nwp.o \
- module_diag_rasm.o \
- module_diag_pld.o \
- module_diag_zld.o \
- module_diag_trad_fields.o \
- module_diag_solar.o
-
-DIAGNOSTIC_MODULES_NMM = \
- module_diag_refl.o
-
-OBJS =
-
-NMM_MODULES =
-
-LIBTARGET = physics
-TARGETDIR = ./
-
-$(LIBTARGET) :
- if [ $(WRF_NMM_CORE) -eq 1 ] ; then \
- $(MAKE) $(J) nmm_contrib ; \
- $(AR) $(ARFLAGS) ../main/$(LIBWRFLIB) $(MODULES) $(OBJS) \
- $(NMM_OBJS) $(NMM_MODULES) \
- $(DIAGNOSTIC_MODULES_NMM) ; \
- else \
- $(MAKE) $(J) non_nmm ; \
- $(AR) $(ARFLAGS) ../main/$(LIBWRFLIB) $(MODULES) $(OBJS) \
- $(FIRE_MODULES) \
- $(DIAGNOSTIC_MODULES_EM) ; \
- fi
-
-include ../configure.wrf
-
-nmm_contrib : $(NMM_OBJS) $(NMM_MODULES) $(MODULES) $(OBJS) $(DIAGNOSTIC_MODULES_NMM)
-
-non_nmm : $(MODULES) $(FIRE_MODULES) $(WIND_MODULES) $(OBJS) $(DIAGNOSTIC_MODULES_EM)
-
-clean:
- @ echo 'use the clean script'
-
-# DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES)
-# DO NOT DELETE
-
-include ../main/depend.common
diff --git a/UTIL/wrfcmaq_twoway_coupler/phys/complex_number_module.F b/UTIL/wrfcmaq_twoway_coupler/phys/complex_number_module.F
deleted file mode 100644
index 3c4e1da9fc..0000000000
--- a/UTIL/wrfcmaq_twoway_coupler/phys/complex_number_module.F
+++ /dev/null
@@ -1,253 +0,0 @@
-!------------------------------------------------------------------------!
-! The Community Multiscale Air Quality (CMAQ) system software is in !
-! continuous development by various groups and is based on information !
-! from these groups: Federal Government employees, contractors working !
-! within a United States Government contract, and non-Federal sources !
-! including research institutions. These groups give the Government !
-! permission to use, prepare derivative works of, and distribute copies !
-! of their work in the CMAQ system to the public and to permit others !
-! to do so. The United States Environmental Protection Agency !
-! therefore grants similar permission to use the CMAQ system software, !
-! but users are requested to provide copies of derivative works or !
-! products designed to operate in the CMAQ system to the United States !
-! Government without restrictions as to use by others. Software !
-! that is used with the CMAQ system but distributed under the GNU !
-! General Public License or the GNU Lesser General Public License is !
-! subject to their copyright restrictions. !
-!------------------------------------------------------------------------!
-
-! complex number general function
-
-! Revision History:
-! 2012/07/31 David Wong Original version
-! 2012/10/22 David Wong Added treatment to avoid division by 0
-! 2013/11/20 David Wong modified the way to compute
-! max(abs(c_div_cc%real_part), min_val) in subroutine
-! c_div_cc to satisfy absoft compiler requirement
-! 2015/12/16 David Wong renamed argument list for c_add_cr, c_add_rc,
-! c_sub_cr and c_sub_rc to avoid gfortran not able to
-! distinguish those routines in the interface block issue
-! 2016/02/23 David Wong extracted the entire module and put it in a
-! file alone.
-
- module complex_number_module
-
- implicit none
-
-! integer, parameter :: loc_real_precision = selected_real_kind(p=16, r=60)
- integer, parameter :: loc_real_precision = 8
-
- real (kind=loc_real_precision), parameter, private :: min_val = 1.0e-30_loc_real_precision
-
- type complex_number
- real(kind=loc_real_precision) :: real_part, imag_part
- end type complex_number
-
- interface c_add
- module procedure c_add_cc, & ! z1 + z2
- c_add_cr, & ! z1 + num, where num is a real number
- c_add_rc ! num + z1, where num is a real number
- end interface
-
- interface c_sub
- module procedure c_sub_cc, & ! z1 - z2
- c_sub_cr, & ! z1 - num, where num is a real number
- c_sub_rc ! num - z1, where num is a real number
- end interface
-
- interface c_mul
- module procedure c_mul_cc, & ! z1 * z2
- c_mul_rc ! num * z1, where num is a real number
- end interface
-
- interface c_div
- module procedure c_div_cc, & ! z1 / z2
- c_div_rc ! num / z1, where num is a real number
- end interface
-
- contains
-
-! --------------------------------------------------------------------------
- type (complex_number) function c_set (x, y)
-
-! initialize a complex number
-
- real(kind=loc_real_precision), intent(in) :: x, y
-
- character (len = 80) :: str
-
- write (str, *) x
- read(str, *) c_set%real_part
- write (str, *) y
- read(str, *) c_set%imag_part
-
- end function c_set
-
-! --------------------------------------------------------------------------
- type (complex_number) function c_add_cc (z1, z2)
-
- type (complex_number), intent(in) :: z1, z2
-
- c_add_cc%real_part = z1%real_part + z2%real_part
- c_add_cc%imag_part = z1%imag_part + z2%imag_part
-
- end function c_add_cc
-
-! --------------------------------------------------------------------------
- type (complex_number) function c_add_cr (z3, num1)
-
- type (complex_number), intent(in) :: z3
- real(kind=loc_real_precision), intent(in) :: num1
-
- c_add_cr%real_part = z3%real_part + num1
- c_add_cr%imag_part = z3%imag_part
-
- end function c_add_cr
-
-! --------------------------------------------------------------------------
- type (complex_number) function c_add_rc (num2, z4)
-
- type (complex_number), intent(in) :: z4
- real(kind=loc_real_precision), intent(in) :: num2
-
- c_add_rc%real_part = z4%real_part + num2
- c_add_rc%imag_part = z4%imag_part
-
- end function c_add_rc
-
-! --------------------------------------------------------------------------
- type (complex_number) function c_sub_cc (z1, z2)
-
- type (complex_number), intent(in) :: z1, z2
-
- c_sub_cc%real_part = z1%real_part - z2%real_part
- c_sub_cc%imag_part = z1%imag_part - z2%imag_part
-
- end function c_sub_cc
-
-! --------------------------------------------------------------------------
- type (complex_number) function c_sub_cr (z3, num1)
-
- type (complex_number), intent(in) :: z3
- real(kind=loc_real_precision), intent(in) :: num1
-
- c_sub_cr%real_part = z3%real_part - num1
- c_sub_cr%imag_part = z3%imag_part
-
- end function c_sub_cr
-
-! --------------------------------------------------------------------------
- type (complex_number) function c_sub_rc (num2, z4)
-
- type (complex_number), intent(in) :: z4
- real(kind=loc_real_precision), intent(in) :: num2
-
- c_sub_rc%real_part = num2 - z4%real_part
- c_sub_rc%imag_part = - z4%imag_part
-
- end function c_sub_rc
-
-! --------------------------------------------------------------------------
- type (complex_number) function c_mul_cc (z1, z2)
-
- type (complex_number), intent(in) :: z1, z2
-
- c_mul_cc%real_part = z1%real_part * z2%real_part &
- - z1%imag_part * z2%imag_part
- c_mul_cc%imag_part = z1%real_part * z2%imag_part &
- + z1%imag_part * z2%real_part
-
- end function c_mul_cc
-
-! --------------------------------------------------------------------------
- type (complex_number) function c_mul_rc (x, z1)
-
- type (complex_number), intent(in) :: z1
- real(kind=loc_real_precision), intent(in) :: x
-
- c_mul_rc%real_part = z1%real_part * x
- c_mul_rc%imag_part = z1%imag_part * x
-
- end function c_mul_rc
-
-! --------------------------------------------------------------------------
- type (complex_number) function c_div_cc (z1, z2)
-
- type (complex_number), intent(in) :: z1, z2
-
- real(kind=loc_real_precision) :: denom
- real(kind=loc_real_precision) :: temp(2)
-
- denom = 1.0 / ( z2%real_part * z2%real_part &
- + z2%imag_part * z2%imag_part)
-
- c_div_cc%real_part = ( z1%real_part * z2%real_part &
- + z1%imag_part * z2%imag_part) * denom
-
- temp(1) = abs(c_div_cc%real_part)
- temp(2) = min_val
-
- c_div_cc%real_part = sign(maxval(temp), c_div_cc%real_part)
-
- c_div_cc%imag_part = ( z1%imag_part * z2%real_part &
- - z1%real_part * z2%imag_part) * denom
-
- temp(1) = abs(c_div_cc%imag_part)
-
- c_div_cc%imag_part = sign(maxval(temp), c_div_cc%imag_part)
-
- end function c_div_cc
-
-! --------------------------------------------------------------------------
- type (complex_number) function c_div_rc (num, z1)
-
-! compute 1 / z1
-
- real(kind=loc_real_precision), intent(in) :: num
- type (complex_number), intent(in) :: z1
-
- real(kind=loc_real_precision) :: denom, temp
-
- temp = z1%real_part * z1%real_part + z1%imag_part * z1%imag_part
- temp = sign(max(abs(temp), min_val), temp)
-
- denom = num / temp
- c_div_rc%real_part = z1%real_part * denom
- c_div_rc%imag_part = -1.0 * z1%imag_part * denom
-
- end function c_div_rc
-
-! --------------------------------------------------------------------------
- type (complex_number) function c_sin (z1)
-
-! compute sin of a complex number
-
- type (complex_number), intent(in) :: z1
-
- c_sin%real_part = sin(z1%real_part) * cosh(z1%imag_part)
- c_sin%imag_part = cos(z1%real_part) * sinh(z1%imag_part)
-
- end function c_sin
-
-! --------------------------------------------------------------------------
- type (complex_number) function c_cos (z1)
-
- type (complex_number), intent(in) :: z1
-
- c_cos%real_part = cos(z1%real_part) * cosh(z1%imag_part)
- c_cos%imag_part = -1.0 * sin(z1%real_part) * sinh(z1%imag_part)
-
- end function c_cos
-
-! --------------------------------------------------------------------------
- real(kind=loc_real_precision) function c_abs (z1)
-
-! computer absolute value of a complex number
-
- type (complex_number), intent(in) :: z1
-
- c_abs = sqrt(z1%real_part**2 + z1%imag_part**2)
-
- end function c_abs
-
- end module complex_number_module
diff --git a/UTIL/wrfcmaq_twoway_coupler/phys/module_ra_rrtmg_sw.F b/UTIL/wrfcmaq_twoway_coupler/phys/module_ra_rrtmg_sw.F
deleted file mode 100644
index 7e43eea3fa..0000000000
--- a/UTIL/wrfcmaq_twoway_coupler/phys/module_ra_rrtmg_sw.F
+++ /dev/null
@@ -1,12665 +0,0 @@
-!!MODULE module_ra_rrtmg_sw
-
- module parrrsw
-
- use parkind ,only : im => kind_im, rb => kind_rb
-
-! implicit none
- save
-
-!------------------------------------------------------------------
-! rrtmg_sw main parameters
-!
-! Initial version: JJMorcrette, ECMWF, jul1998
-! Revised: MJIacono, AER, jun2006
-! Revised: MJIacono, AER, aug2008
-!------------------------------------------------------------------
-
-! name type purpose
-! ----- : ---- : ----------------------------------------------
-! mxlay : integer: maximum number of layers
-! mg : integer: number of original g-intervals per spectral band
-! nbndsw : integer: number of spectral bands
-! naerec : integer: number of aerosols (iaer=6, ecmwf aerosol option)
-! ngptsw : integer: total number of reduced g-intervals for rrtmg_lw
-! ngNN : integer: number of reduced g-intervals per spectral band
-! ngsNN : integer: cumulative number of g-intervals per band
-!------------------------------------------------------------------
-
- integer(kind=im), parameter :: mxlay = 203 !jplay, klev
- integer(kind=im), parameter :: mg = 16 !jpg
- integer(kind=im), parameter :: nbndsw = 14 !jpsw, ksw
- integer(kind=im), parameter :: naerec = 6 !jpaer
- integer(kind=im), parameter :: mxmol = 38
- integer(kind=im), parameter :: nstr = 2
- integer(kind=im), parameter :: nmol = 7
-! Use for 112 g-point model
- integer(kind=im), parameter :: ngptsw = 112 !jpgpt
-! Use for 224 g-point model
-! integer(kind=im), parameter :: ngptsw = 224 !jpgpt
-
-! may need to rename these - from v2.6
- integer(kind=im), parameter :: jpband = 29
- integer(kind=im), parameter :: jpb1 = 16 !istart
- integer(kind=im), parameter :: jpb2 = 29 !iend
-
- integer(kind=im), parameter :: jmcmu = 32
- integer(kind=im), parameter :: jmumu = 32
- integer(kind=im), parameter :: jmphi = 3
- integer(kind=im), parameter :: jmxang = 4
- integer(kind=im), parameter :: jmxstr = 16
-
-! Use for 112 g-point model
- integer(kind=im), parameter :: ng16 = 6
- integer(kind=im), parameter :: ng17 = 12
- integer(kind=im), parameter :: ng18 = 8
- integer(kind=im), parameter :: ng19 = 8
- integer(kind=im), parameter :: ng20 = 10
- integer(kind=im), parameter :: ng21 = 10
- integer(kind=im), parameter :: ng22 = 2
- integer(kind=im), parameter :: ng23 = 10
- integer(kind=im), parameter :: ng24 = 8
- integer(kind=im), parameter :: ng25 = 6
- integer(kind=im), parameter :: ng26 = 6
- integer(kind=im), parameter :: ng27 = 8
- integer(kind=im), parameter :: ng28 = 6
- integer(kind=im), parameter :: ng29 = 12
-
- integer(kind=im), parameter :: ngs16 = 6
- integer(kind=im), parameter :: ngs17 = 18
- integer(kind=im), parameter :: ngs18 = 26
- integer(kind=im), parameter :: ngs19 = 34
- integer(kind=im), parameter :: ngs20 = 44
- integer(kind=im), parameter :: ngs21 = 54
- integer(kind=im), parameter :: ngs22 = 56
- integer(kind=im), parameter :: ngs23 = 66
- integer(kind=im), parameter :: ngs24 = 74
- integer(kind=im), parameter :: ngs25 = 80
- integer(kind=im), parameter :: ngs26 = 86
- integer(kind=im), parameter :: ngs27 = 94
- integer(kind=im), parameter :: ngs28 = 100
- integer(kind=im), parameter :: ngs29 = 112
-
-! Use for 224 g-point model
-! integer(kind=im), parameter :: ng16 = 16
-! integer(kind=im), parameter :: ng17 = 16
-! integer(kind=im), parameter :: ng18 = 16
-! integer(kind=im), parameter :: ng19 = 16
-! integer(kind=im), parameter :: ng20 = 16
-! integer(kind=im), parameter :: ng21 = 16
-! integer(kind=im), parameter :: ng22 = 16
-! integer(kind=im), parameter :: ng23 = 16
-! integer(kind=im), parameter :: ng24 = 16
-! integer(kind=im), parameter :: ng25 = 16
-! integer(kind=im), parameter :: ng26 = 16
-! integer(kind=im), parameter :: ng27 = 16
-! integer(kind=im), parameter :: ng28 = 16
-! integer(kind=im), parameter :: ng29 = 16
-
-! integer(kind=im), parameter :: ngs16 = 16
-! integer(kind=im), parameter :: ngs17 = 32
-! integer(kind=im), parameter :: ngs18 = 48
-! integer(kind=im), parameter :: ngs19 = 64
-! integer(kind=im), parameter :: ngs20 = 80
-! integer(kind=im), parameter :: ngs21 = 96
-! integer(kind=im), parameter :: ngs22 = 112
-! integer(kind=im), parameter :: ngs23 = 128
-! integer(kind=im), parameter :: ngs24 = 144
-! integer(kind=im), parameter :: ngs25 = 160
-! integer(kind=im), parameter :: ngs26 = 176
-! integer(kind=im), parameter :: ngs27 = 192
-! integer(kind=im), parameter :: ngs28 = 208
-! integer(kind=im), parameter :: ngs29 = 224
-
-! Source function solar constant
- real(kind=rb), parameter :: rrsw_scon = 1.36822e+03 ! W/m2
-
- end module parrrsw
-
- module rrsw_aer
-
- use parkind, only : im => kind_im, rb => kind_rb
- use parrrsw, only : nbndsw, naerec
-
-! implicit none
- save
-
-!------------------------------------------------------------------
-! rrtmg_sw aerosol optical properties
-!
-! Data derived from six ECMWF aerosol types and defined for
-! the rrtmg_sw spectral intervals
-!
-! Initial: J.-J. Morcrette, ECMWF, mar2003
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!------------------------------------------------------------------
-!
-!-- The six ECMWF aerosol types are respectively:
-!
-! 1/ continental average 2/ maritime
-! 3/ desert 4/ urban
-! 5/ volcanic active 6/ stratospheric background
-!
-! computed from Hess and Koepke (con, mar, des, urb)
-! from Bonnel et al. (vol, str)
-!
-! rrtmg_sw 14 spectral intervals (microns):
-! 3.846 - 3.077
-! 3.077 - 2.500
-! 2.500 - 2.150
-! 2.150 - 1.942
-! 1.942 - 1.626
-! 1.626 - 1.299
-! 1.299 - 1.242
-! 1.242 - 0.7782
-! 0.7782- 0.6250
-! 0.6250- 0.4415
-! 0.4415- 0.3448
-! 0.3448- 0.2632
-! 0.2632- 0.2000
-! 12.195 - 3.846
-!
-!------------------------------------------------------------------
-!
-! name type purpose
-! ----- : ---- : ----------------------------------------------
-! rsrtaua : real : ratio of average optical thickness in
-! spectral band to that at 0.55 micron
-! rsrpiza : real : average single scattering albedo (unitless)
-! rsrasya : real : average asymmetry parameter (unitless)
-!------------------------------------------------------------------
-
- real(kind=rb) :: rsrtaua(nbndsw,naerec)
- real(kind=rb) :: rsrpiza(nbndsw,naerec)
- real(kind=rb) :: rsrasya(nbndsw,naerec)
-
- end module rrsw_aer
-
- module rrsw_cld
-
- use parkind, only : im => kind_im, rb => kind_rb
-
-! implicit none
- save
-
-!------------------------------------------------------------------
-! rrtmg_sw cloud property coefficients
-!
-! Initial: J.-J. Morcrette, ECMWF, oct1999
-! Revised: J. Delamere/MJIacono, AER, aug2005
-! Revised: MJIacono, AER, nov2005
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!------------------------------------------------------------------
-!
-! name type purpose
-! ----- : ---- : ----------------------------------------------
-! xxxliq1 : real : optical properties (extinction coefficient, single
-! scattering albedo, assymetry factor) from
-! Hu & Stamnes, j. clim., 6, 728-742, 1993.
-! xxxice2 : real : optical properties (extinction coefficient, single
-! scattering albedo, assymetry factor) from streamer v3.0,
-! Key, streamer user's guide, cooperative institude
-! for meteorological studies, 95 pp., 2001.
-! xxxice3 : real : optical properties (extinction coefficient, single
-! scattering albedo, assymetry factor) from
-! Fu, j. clim., 9, 1996.
-! xbari : real : optical property coefficients for five spectral
-! intervals (2857-4000, 4000-5263, 5263-7692, 7692-14285,
-! and 14285-40000 wavenumbers) following
-! Ebert and Curry, jgr, 97, 3831-3836, 1992.
-!------------------------------------------------------------------
-
- real(kind=rb) :: extliq1(58,16:29), ssaliq1(58,16:29), asyliq1(58,16:29)
- real(kind=rb) :: extice2(43,16:29), ssaice2(43,16:29), asyice2(43,16:29)
- real(kind=rb) :: extice3(46,16:29), ssaice3(46,16:29), asyice3(46,16:29)
- real(kind=rb) :: fdlice3(46,16:29)
- real(kind=rb) :: abari(5),bbari(5),cbari(5),dbari(5),ebari(5),fbari(5)
-
- end module rrsw_cld
-
- module rrsw_con
-
- use parkind, only : im => kind_im, rb => kind_rb
-
-! implicit none
- save
-
-!------------------------------------------------------------------
-! rrtmg_sw constants
-
-! Initial version: MJIacono, AER, jun2006
-! Revised: MJIacono, AER, aug2008
-!------------------------------------------------------------------
-
-! name type purpose
-! ----- : ---- : ----------------------------------------------
-! fluxfac: real : radiance to flux conversion factor
-! heatfac: real : flux to heating rate conversion factor
-!oneminus: real : 1.-1.e-6
-! pi : real : pi
-! grav : real : acceleration of gravity
-! planck : real : planck constant
-! boltz : real : boltzmann constant
-! clight : real : speed of light
-! avogad : real : avogadro constant
-! alosmt : real : loschmidt constant
-! gascon : real : molar gas constant
-! radcn1 : real : first radiation constant
-! radcn2 : real : second radiation constant
-! sbcnst : real : stefan-boltzmann constant
-! secdy : real : seconds per day
-!------------------------------------------------------------------
-
- real(kind=rb) :: fluxfac, heatfac
- real(kind=rb) :: oneminus, pi, grav
- real(kind=rb) :: planck, boltz, clight
- real(kind=rb) :: avogad, alosmt, gascon
- real(kind=rb) :: radcn1, radcn2
- real(kind=rb) :: sbcnst, secdy
-
- end module rrsw_con
-
- module rrsw_kg16
-
- use parkind ,only : im => kind_im, rb => kind_rb
- use parrrsw, only : ng16
-
-! implicit none
- save
-
-!-----------------------------------------------------------------
-! rrtmg_sw ORIGINAL abs. coefficients for interval 16
-! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! kao : real
-! kbo : real
-! selfrefo: real
-! forrefo : real
-!sfluxrefo: real
-!-----------------------------------------------------------------
-
- integer(kind=im), parameter :: no16 = 16
-
- real(kind=rb) :: kao(9,5,13,no16)
- real(kind=rb) :: kbo(5,13:59,no16)
- real(kind=rb) :: selfrefo(10,no16), forrefo(3,no16)
- real(kind=rb) :: sfluxrefo(no16)
-
- integer(kind=im) :: layreffr
- real(kind=rb) :: rayl, strrat1
-
-!-----------------------------------------------------------------
-! rrtmg_sw COMBINED abs. coefficients for interval 16
-! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! ka : real
-! kb : real
-! absa : real
-! absb : real
-! selfref : real
-! forref : real
-! sfluxref: real
-!-----------------------------------------------------------------
-
- real(kind=rb) :: ka(9,5,13,ng16) , absa(585,ng16)
- real(kind=rb) :: kb(5,13:59,ng16), absb(235,ng16)
- real(kind=rb) :: selfref(10,ng16), forref(3,ng16)
- real(kind=rb) :: sfluxref(ng16)
-
- equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
-
- end module rrsw_kg16
-
- module rrsw_kg17
-
- use parkind ,only : im => kind_im, rb => kind_rb
- use parrrsw, only : ng17
-
-! implicit none
- save
-
-!-----------------------------------------------------------------
-! rrtmg_sw ORIGINAL abs. coefficients for interval 17
-! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! kao : real
-! kbo : real
-! selfrefo: real
-! forrefo : real
-!sfluxrefo: real
-!-----------------------------------------------------------------
-
- integer(kind=im), parameter :: no17 = 16
-
- real(kind=rb) :: kao(9,5,13,no17)
- real(kind=rb) :: kbo(5,5,13:59,no17)
- real(kind=rb) :: selfrefo(10,no17), forrefo(4,no17)
- real(kind=rb) :: sfluxrefo(no17,5)
-
- integer(kind=im) :: layreffr
- real(kind=rb) :: rayl, strrat
-
-!-----------------------------------------------------------------
-! rrtmg_sw COMBINED abs. coefficients for interval 17
-! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! ka : real
-! kb : real
-! absa : real
-! absb : real
-! selfref : real
-! forref : real
-! sfluxref: real
-!-----------------------------------------------------------------
-
- real(kind=rb) :: ka(9,5,13,ng17) , absa(585,ng17)
- real(kind=rb) :: kb(5,5,13:59,ng17), absb(1175,ng17)
- real(kind=rb) :: selfref(10,ng17), forref(4,ng17)
- real(kind=rb) :: sfluxref(ng17,5)
-
- equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1))
-
- end module rrsw_kg17
-
- module rrsw_kg18
-
- use parkind ,only : im => kind_im, rb => kind_rb
- use parrrsw, only : ng18
-
-! implicit none
- save
-
-!-----------------------------------------------------------------
-! rrtmg_sw ORIGINAL abs. coefficients for interval 18
-! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! kao : real
-! kbo : real
-! selfrefo: real
-! forrefo : real
-!sfluxrefo: real
-!-----------------------------------------------------------------
-
- integer(kind=im), parameter :: no18 = 16
-
- real(kind=rb) :: kao(9,5,13,no18)
- real(kind=rb) :: kbo(5,13:59,no18)
- real(kind=rb) :: selfrefo(10,no18), forrefo(3,no18)
- real(kind=rb) :: sfluxrefo(no18,9)
-
- integer(kind=im) :: layreffr
- real(kind=rb) :: rayl, strrat
-
-!-----------------------------------------------------------------
-! rrtmg_sw COMBINED abs. coefficients for interval 18
-! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! ka : real
-! kb : real
-! absa : real
-! absb : real
-! selfref : real
-! forref : real
-! sfluxref: real
-!-----------------------------------------------------------------
-
- real(kind=rb) :: ka(9,5,13,ng18), absa(585,ng18)
- real(kind=rb) :: kb(5,13:59,ng18), absb(235,ng18)
- real(kind=rb) :: selfref(10,ng18), forref(3,ng18)
- real(kind=rb) :: sfluxref(ng18,9)
-
- equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
-
- end module rrsw_kg18
-
- module rrsw_kg19
-
- use parkind ,only : im => kind_im, rb => kind_rb
- use parrrsw, only : ng19
-
-! implicit none
- save
-
-!-----------------------------------------------------------------
-! rrtmg_sw ORIGINAL abs. coefficients for interval 19
-! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! kao : real
-! kbo : real
-! selfrefo: real
-! forrefo : real
-!sfluxrefo: real
-!-----------------------------------------------------------------
-
- integer(kind=im), parameter :: no19 = 16
-
- real(kind=rb) :: kao(9,5,13,no19)
- real(kind=rb) :: kbo(5,13:59,no19)
- real(kind=rb) :: selfrefo(10,no19), forrefo(3,no19)
- real(kind=rb) :: sfluxrefo(no19,9)
-
- integer(kind=im) :: layreffr
- real(kind=rb) :: rayl, strrat
-
-!-----------------------------------------------------------------
-! rrtmg_sw COMBINED abs. coefficients for interval 19
-! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! ka : real
-! kb : real
-! absa : real
-! absb : real
-! selfref : real
-! forref : real
-! sfluxref: real
-!-----------------------------------------------------------------
-
- real(kind=rb) :: ka(9,5,13,ng19), absa(585,ng19)
- real(kind=rb) :: kb(5,13:59,ng19), absb(235,ng19)
- real(kind=rb) :: selfref(10,ng19), forref(3,ng19)
- real(kind=rb) :: sfluxref(ng19,9)
-
- equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
-
- end module rrsw_kg19
-
- module rrsw_kg20
-
- use parkind ,only : im => kind_im, rb => kind_rb
- use parrrsw, only : ng20
-
-! implicit none
- save
-
-!-----------------------------------------------------------------
-! rrtmg_sw ORIGINAL abs. coefficients for interval 20
-! band 20: 5150-6150 cm-1 (low - h2o; high - h2o)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! kao : real
-! kbo : real
-! selfrefo: real
-! forrefo : real
-!sfluxrefo: real
-! absch4o : real
-!-----------------------------------------------------------------
-
- integer(kind=im), parameter :: no20 = 16
-
- real(kind=rb) :: kao(5,13,no20)
- real(kind=rb) :: kbo(5,13:59,no20)
- real(kind=rb) :: selfrefo(10,no20), forrefo(4,no20)
- real(kind=rb) :: sfluxrefo(no20)
- real(kind=rb) :: absch4o(no20)
-
- integer(kind=im) :: layreffr
- real(kind=rb) :: rayl
-
-!-----------------------------------------------------------------
-! rrtmg_sw COMBINED abs. coefficients for interval 20
-! band 20: 5150-6150 cm-1 (low - h2o; high - h2o)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! ka : real
-! kb : real
-! absa : real
-! absb : real
-! selfref : real
-! forref : real
-! sfluxref: real
-! absch4 : real
-!-----------------------------------------------------------------
-
- real(kind=rb) :: ka(5,13,ng20), absa(65,ng20)
- real(kind=rb) :: kb(5,13:59,ng20), absb(235,ng20)
- real(kind=rb) :: selfref(10,ng20), forref(4,ng20)
- real(kind=rb) :: sfluxref(ng20)
- real(kind=rb) :: absch4(ng20)
-
- equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
-
- end module rrsw_kg20
-
- module rrsw_kg21
-
- use parkind ,only : im => kind_im, rb => kind_rb
- use parrrsw, only : ng21
-
-! implicit none
- save
-
-!-----------------------------------------------------------------
-! rrtmg_sw ORIGINAL abs. coefficients for interval 21
-! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! kao : real
-! kbo : real
-! selfrefo: real
-! forrefo : real
-!sfluxrefo: real
-!-----------------------------------------------------------------
-
- integer(kind=im), parameter :: no21 = 16
-
- real(kind=rb) :: kao(9,5,13,no21)
- real(kind=rb) :: kbo(5,5,13:59,no21)
- real(kind=rb) :: selfrefo(10,no21), forrefo(4,no21)
- real(kind=rb) :: sfluxrefo(no21,9)
-
- integer(kind=im) :: layreffr
- real(kind=rb) :: rayl, strrat
-
-!-----------------------------------------------------------------
-! rrtmg_sw COMBINED abs. coefficients for interval 21
-! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! ka : real
-! kb : real
-! absa : real
-! absb : real
-! selfref : real
-! forref : real
-! sfluxref: real
-!-----------------------------------------------------------------
-
- real(kind=rb) :: ka(9,5,13,ng21), absa(585,ng21)
- real(kind=rb) :: kb(5,5,13:59,ng21), absb(1175,ng21)
- real(kind=rb) :: selfref(10,ng21), forref(4,ng21)
- real(kind=rb) :: sfluxref(ng21,9)
-
- equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1))
-
- end module rrsw_kg21
-
- module rrsw_kg22
-
- use parkind ,only : im => kind_im, rb => kind_rb
- use parrrsw, only : ng22
-
-! implicit none
- save
-
-!-----------------------------------------------------------------
-! rrtmg_sw ORIGINAL abs. coefficients for interval 22
-! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! kao : real
-! kbo : real
-! selfrefo: real
-! forrefo : real
-!sfluxrefo: real
-!-----------------------------------------------------------------
-
- integer(kind=im), parameter :: no22 = 16
-
- real(kind=rb) :: kao(9,5,13,no22)
- real(kind=rb) :: kbo(5,13:59,no22)
- real(kind=rb) :: selfrefo(10,no22), forrefo(3,no22)
- real(kind=rb) :: sfluxrefo(no22,9)
-
- integer(kind=im) :: layreffr
- real(kind=rb) :: rayl, strrat
-
-!-----------------------------------------------------------------
-! rrtmg_sw COMBINED abs. coefficients for interval 22
-! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! ka : real
-! kb : real
-! absa : real
-! absb : real
-! selfref : real
-! forref : real
-! sfluxref: real
-!-----------------------------------------------------------------
-
- real(kind=rb) :: ka(9,5,13,ng22), absa(585,ng22)
- real(kind=rb) :: kb(5,13:59,ng22), absb(235,ng22)
- real(kind=rb) :: selfref(10,ng22), forref(3,ng22)
- real(kind=rb) :: sfluxref(ng22,9)
-
- equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
-
- end module rrsw_kg22
-
- module rrsw_kg23
-
- use parkind ,only : im => kind_im, rb => kind_rb
- use parrrsw, only : ng23
-
-! implicit none
- save
-
-!-----------------------------------------------------------------
-! rrtmg_sw ORIGINAL abs. coefficients for interval 23
-! band 23: 8050-12850 cm-1 (low - h2o; high - nothing)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! kao : real
-! kbo : real
-! selfrefo: real
-! forrefo : real
-!sfluxrefo: real
-!-----------------------------------------------------------------
-
- integer(kind=im), parameter :: no23 = 16
-
- real(kind=rb) :: kao(5,13,no23)
- real(kind=rb) :: selfrefo(10,no23), forrefo(3,no23)
- real(kind=rb) :: sfluxrefo(no23)
- real(kind=rb) :: raylo(no23)
-
- integer(kind=im) :: layreffr
- real(kind=rb) :: givfac
-
-!-----------------------------------------------------------------
-! rrtmg_sw COMBINED abs. coefficients for interval 23
-! band 23: 8050-12850 cm-1 (low - h2o; high - nothing)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! ka : real
-! kb : real
-! absa : real
-! absb : real
-! selfref : real
-! forref : real
-! sfluxref: real
-!-----------------------------------------------------------------
-
- real(kind=rb) :: ka(5,13,ng23), absa(65,ng23)
- real(kind=rb) :: selfref(10,ng23), forref(3,ng23)
- real(kind=rb) :: sfluxref(ng23), rayl(ng23)
-
- equivalence (ka(1,1,1),absa(1,1))
-
- end module rrsw_kg23
-
- module rrsw_kg24
-
- use parkind ,only : im => kind_im, rb => kind_rb
- use parrrsw, only : ng24
-
-! implicit none
- save
-
-!-----------------------------------------------------------------
-! rrtmg_sw ORIGINAL abs. coefficients for interval 24
-! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! kao : real
-! kbo : real
-! selfrefo: real
-! forrefo : real
-!sfluxrefo: real
-! abso3ao : real
-! abso3bo : real
-! raylao : real
-! raylbo : real
-!-----------------------------------------------------------------
-
- integer(kind=im), parameter :: no24 = 16
-
- real(kind=rb) :: kao(9,5,13,no24)
- real(kind=rb) :: kbo(5,13:59,no24)
- real(kind=rb) :: selfrefo(10,no24), forrefo(3,no24)
- real(kind=rb) :: sfluxrefo(no24,9)
- real(kind=rb) :: abso3ao(no24), abso3bo(no24)
- real(kind=rb) :: raylao(no24,9), raylbo(no24)
-
- integer(kind=im) :: layreffr
- real(kind=rb) :: strrat
-
-!-----------------------------------------------------------------
-! rrtmg_sw COMBINED abs. coefficients for interval 24
-! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! ka : real
-! kb : real
-! absa : real
-! absb : real
-! selfref : real
-! forref : real
-! sfluxref: real
-! abso3a : real
-! abso3b : real
-! rayla : real
-! raylb : real
-!-----------------------------------------------------------------
-
- real(kind=rb) :: ka(9,5,13,ng24), absa(585,ng24)
- real(kind=rb) :: kb(5,13:59,ng24), absb(235,ng24)
- real(kind=rb) :: selfref(10,ng24), forref(3,ng24)
- real(kind=rb) :: sfluxref(ng24,9)
- real(kind=rb) :: abso3a(ng24), abso3b(ng24)
- real(kind=rb) :: rayla(ng24,9), raylb(ng24)
-
- equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
-
- end module rrsw_kg24
-
- module rrsw_kg25
-
- use parkind ,only : im => kind_im, rb => kind_rb
- use parrrsw, only : ng25
-
-! implicit none
- save
-
-!-----------------------------------------------------------------
-! rrtmg_sw ORIGINAL abs. coefficients for interval 25
-! band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! kao : real
-!sfluxrefo: real
-! abso3ao : real
-! abso3bo : real
-! raylo : real
-!-----------------------------------------------------------------
-
- integer(kind=im), parameter :: no25 = 16
-
- real(kind=rb) :: kao(5,13,no25)
- real(kind=rb) :: sfluxrefo(no25)
- real(kind=rb) :: abso3ao(no25), abso3bo(no25)
- real(kind=rb) :: raylo(no25)
-
- integer(kind=im) :: layreffr
-
-!-----------------------------------------------------------------
-! rrtmg_sw COMBINED abs. coefficients for interval 25
-! band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! ka : real
-! absa : real
-! sfluxref: real
-! abso3a : real
-! abso3b : real
-! rayl : real
-!-----------------------------------------------------------------
-
- real(kind=rb) :: ka(5,13,ng25), absa(65,ng25)
- real(kind=rb) :: sfluxref(ng25)
- real(kind=rb) :: abso3a(ng25), abso3b(ng25)
- real(kind=rb) :: rayl(ng25)
-
- equivalence (ka(1,1,1),absa(1,1))
-
- end module rrsw_kg25
-
- module rrsw_kg26
-
- use parkind ,only : im => kind_im, rb => kind_rb
- use parrrsw, only : ng26
-
-! implicit none
- save
-
-!-----------------------------------------------------------------
-! rrtmg_sw ORIGINAL abs. coefficients for interval 26
-! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-!sfluxrefo: real
-! raylo : real
-!-----------------------------------------------------------------
-
- integer(kind=im), parameter :: no26 = 16
-
- real(kind=rb) :: sfluxrefo(no26)
- real(kind=rb) :: raylo(no26)
-
-!-----------------------------------------------------------------
-! rrtmg_sw COMBINED abs. coefficients for interval 26
-! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! sfluxref: real
-! rayl : real
-!-----------------------------------------------------------------
-
- real(kind=rb) :: sfluxref(ng26)
- real(kind=rb) :: rayl(ng26)
-
- end module rrsw_kg26
-
- module rrsw_kg27
-
- use parkind ,only : im => kind_im, rb => kind_rb
- use parrrsw, only : ng27
-
-! implicit none
- save
-
-!-----------------------------------------------------------------
-! rrtmg_sw ORIGINAL abs. coefficients for interval 27
-! band 27: 29000-38000 cm-1 (low - o3; high - o3)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! kao : real
-! kbo : real
-!sfluxrefo: real
-! raylo : real
-!-----------------------------------------------------------------
-
- integer(kind=im), parameter :: no27 = 16
-
- real(kind=rb) :: kao(5,13,no27)
- real(kind=rb) :: kbo(5,13:59,no27)
- real(kind=rb) :: sfluxrefo(no27)
- real(kind=rb) :: raylo(no27)
-
- integer(kind=im) :: layreffr
- real(kind=rb) :: scalekur
-
-!-----------------------------------------------------------------
-! rrtmg_sw COMBINED abs. coefficients for interval 27
-! band 27: 29000-38000 cm-1 (low - o3; high - o3)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! ka : real
-! kb : real
-! absa : real
-! absb : real
-! sfluxref: real
-! rayl : real
-!-----------------------------------------------------------------
-
- real(kind=rb) :: ka(5,13,ng27), absa(65,ng27)
- real(kind=rb) :: kb(5,13:59,ng27), absb(235,ng27)
- real(kind=rb) :: sfluxref(ng27)
- real(kind=rb) :: rayl(ng27)
-
- equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
-
- end module rrsw_kg27
-
- module rrsw_kg28
-
- use parkind ,only : im => kind_im, rb => kind_rb
- use parrrsw, only : ng28
-
-! implicit none
- save
-
-!-----------------------------------------------------------------
-! rrtmg_sw ORIGINAL abs. coefficients for interval 28
-! band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! kao : real
-! kbo : real
-!sfluxrefo: real
-!-----------------------------------------------------------------
-
- integer(kind=im), parameter :: no28 = 16
-
- real(kind=rb) :: kao(9,5,13,no28)
- real(kind=rb) :: kbo(5,5,13:59,no28)
- real(kind=rb) :: sfluxrefo(no28,5)
-
- integer(kind=im) :: layreffr
- real(kind=rb) :: rayl, strrat
-
-!-----------------------------------------------------------------
-! rrtmg_sw COMBINED abs. coefficients for interval 28
-! band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! ka : real
-! kb : real
-! sfluxref: real
-!-----------------------------------------------------------------
-
- real(kind=rb) :: ka(9,5,13,ng28), absa(585,ng28)
- real(kind=rb) :: kb(5,5,13:59,ng28), absb(1175,ng28)
- real(kind=rb) :: sfluxref(ng28,5)
-
- equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1))
-
- end module rrsw_kg28
-
- module rrsw_kg29
-
- use parkind ,only : im => kind_im, rb => kind_rb
- use parrrsw, only : ng29
-
-! implicit none
- save
-
-!-----------------------------------------------------------------
-! rrtmg_sw ORIGINAL abs. coefficients for interval 29
-! band 29: 820-2600 cm-1 (low - h2o; high - co2)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! kao : real
-! kbo : real
-! selfrefo: real
-! forrefo : real
-!sfluxrefo: real
-! absh2oo : real
-! absco2o : real
-!-----------------------------------------------------------------
-
- integer(kind=im), parameter :: no29 = 16
-
- real(kind=rb) :: kao(5,13,no29)
- real(kind=rb) :: kbo(5,13:59,no29)
- real(kind=rb) :: selfrefo(10,no29), forrefo(4,no29)
- real(kind=rb) :: sfluxrefo(no29)
- real(kind=rb) :: absh2oo(no29), absco2o(no29)
-
- integer(kind=im) :: layreffr
- real(kind=rb) :: rayl
-
-!-----------------------------------------------------------------
-! rrtmg_sw COMBINED abs. coefficients for interval 29
-! band 29: 820-2600 cm-1 (low - h2o; high - co2)
-!
-! Initial version: JJMorcrette, ECMWF, oct1999
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!-----------------------------------------------------------------
-!
-! name type purpose
-! ---- : ---- : ---------------------------------------------
-! ka : real
-! kb : real
-! selfref : real
-! forref : real
-! sfluxref: real
-! absh2o : real
-! absco2 : real
-!-----------------------------------------------------------------
-
- real(kind=rb) :: ka(5,13,ng29), absa(65,ng29)
- real(kind=rb) :: kb(5,13:59,ng29), absb(235,ng29)
- real(kind=rb) :: selfref(10,ng29), forref(4,ng29)
- real(kind=rb) :: sfluxref(ng29)
- real(kind=rb) :: absh2o(ng29), absco2(ng29)
-
- equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
-
- end module rrsw_kg29
-
- module rrsw_ref
-
- use parkind, only : im => kind_im, rb => kind_rb
-
-! implicit none
- save
-
-!------------------------------------------------------------------
-! rrtmg_sw reference atmosphere
-! Based on standard mid-latitude summer profile
-!
-! Initial version: JJMorcrette, ECMWF, jul1998
-! Revised: MJIacono, AER, jun2006
-! Revised: MJIacono, AER, aug2008
-!------------------------------------------------------------------
-
-! name type purpose
-! ----- : ---- : ----------------------------------------------
-! pref : real : Reference pressure levels
-! preflog: real : Reference pressure levels, ln(pref)
-! tref : real : Reference temperature levels for MLS profile
-!------------------------------------------------------------------
-
- real(kind=rb) , dimension(59) :: pref
- real(kind=rb) , dimension(59) :: preflog
- real(kind=rb) , dimension(59) :: tref
-
- end module rrsw_ref
-
- module rrsw_tbl
-
- use parkind, only : im => kind_im, rb => kind_rb
-
-! implicit none
- save
-
-!------------------------------------------------------------------
-! rrtmg_sw lookup table arrays
-
-! Initial version: MJIacono, AER, may2007
-! Revised: MJIacono, AER, aug2007
-! Revised: MJIacono, AER, aug2008
-!------------------------------------------------------------------
-
-! name type purpose
-! ----- : ---- : ----------------------------------------------
-! ntbl : integer: Lookup table dimension
-! tblint : real : Lookup table conversion factor
-! tau_tbl: real : Clear-sky optical depth
-! exp_tbl: real : Exponential lookup table for transmittance
-! od_lo : real : Value of tau below which expansion is used
-! : in place of lookup table
-! pade : real : Pade approximation constant
-! bpade : real : Inverse of Pade constant
-!------------------------------------------------------------------
-
- integer(kind=im), parameter :: ntbl = 10000
-
- real(kind=rb), parameter :: tblint = 10000.0_rb
-
- real(kind=rb), parameter :: od_lo = 0.06_rb
-
- real(kind=rb) :: tau_tbl
- real(kind=rb) , dimension(0:ntbl) :: exp_tbl
-
- real(kind=rb), parameter :: pade = 0.278_rb
- real(kind=rb) :: bpade
-
- end module rrsw_tbl
-
- module rrsw_vsn
-
-! implicit none
- save
-
-!------------------------------------------------------------------
-! rrtmg_sw version information
-
-! Initial version: JJMorcrette, ECMWF, jul1998
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!------------------------------------------------------------------
-
-! name type purpose
-! ----- : ---- : ----------------------------------------------
-!hnamrtm :character:
-!hnamini :character:
-!hnamcld :character:
-!hnamclc :character:
-!hnamrft :character:
-!hnamspv :character:
-!hnamspc :character:
-!hnamset :character:
-!hnamtau :character:
-!hnamvqd :character:
-!hnamatm :character:
-!hnamutl :character:
-!hnamext :character:
-!hnamkg :character:
-!
-! hvrrtm :character:
-! hvrini :character:
-! hvrcld :character:
-! hvrclc :character:
-! hvrrft :character:
-! hvrspv :character:
-! hvrspc :character:
-! hvrset :character:
-! hvrtau :character:
-! hvrvqd :character:
-! hvratm :character:
-! hvrutl :character:
-! hvrext :character:
-! hvrkg :character:
-!------------------------------------------------------------------
-
- character*18 hvrrtm,hvrini,hvrcld,hvrclc,hvrrft,hvrspv, &
- hvrspc,hvrset,hvrtau,hvrvqd,hvratm,hvrutl,hvrext
- character*20 hnamrtm,hnamini,hnamcld,hnamclc,hnamrft,hnamspv, &
- hnamspc,hnamset,hnamtau,hnamvqd,hnamatm,hnamutl,hnamext
-
- character*18 hvrkg
- character*20 hnamkg
-
- end module rrsw_vsn
-
- module rrsw_wvn
-
- use parkind, only : im => kind_im, rb => kind_rb
- use parrrsw, only : nbndsw, mg, ngptsw, jpb1, jpb2
-
-! implicit none
- save
-
-!------------------------------------------------------------------
-! rrtmg_sw spectral information
-
-! Initial version: JJMorcrette, ECMWF, jul1998
-! Revised: MJIacono, AER, jul2006
-! Revised: MJIacono, AER, aug2008
-!------------------------------------------------------------------
-
-! name type purpose
-! ----- : ---- : ----------------------------------------------
-! ng : integer: Number of original g-intervals in each spectral band
-! nspa : integer:
-! nspb : integer:
-!wavenum1: real : Spectral band lower boundary in wavenumbers
-!wavenum2: real : Spectral band upper boundary in wavenumbers
-! delwave: real : Spectral band width in wavenumbers
-!
-! ngc : integer: The number of new g-intervals in each band
-! ngs : integer: The cumulative sum of new g-intervals for each band
-! ngm : integer: The index of each new g-interval relative to the
-! original 16 g-intervals in each band
-! ngn : integer: The number of original g-intervals that are
-! combined to make each new g-intervals in each band
-! ngb : integer: The band index for each new g-interval
-! wt : real : RRTM weights for the original 16 g-intervals
-! rwgt : real : Weights for combining original 16 g-intervals
-! (224 total) into reduced set of g-intervals
-! (112 total)
-!------------------------------------------------------------------
-
- integer(kind=im) :: ng(jpb1:jpb2)
- integer(kind=im) :: nspa(jpb1:jpb2)
- integer(kind=im) :: nspb(jpb1:jpb2)
-
- real(kind=rb) :: wavenum1(jpb1:jpb2)
- real(kind=rb) :: wavenum2(jpb1:jpb2)
- real(kind=rb) :: delwave(jpb1:jpb2)
-
- integer(kind=im) :: ngc(nbndsw)
- integer(kind=im) :: ngs(nbndsw)
- integer(kind=im) :: ngn(ngptsw)
- integer(kind=im) :: ngb(ngptsw)
- integer(kind=im) :: ngm(nbndsw*mg)
-
- real(kind=rb) :: wt(mg)
- real(kind=rb) :: rwgt(nbndsw*mg)
-
- end module rrsw_wvn
-
-! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
-! author: $Author: trn $
-! revision: $Revision: 1.3 $
-! created: $Date: 2009/04/16 19:54:22 $
-!
- module mcica_subcol_gen_sw
-
-! --------------------------------------------------------------------------
-! | |
-! | Copyright 2006-2008, Atmospheric & Environmental Research, Inc. (AER). |
-! | This software may be used, copied, or redistributed as long as it is |
-! | not sold and this copyright notice is reproduced on each copy made. |
-! | This model is provided as is without any express or implied warranties. |
-! | (http://www.rtweb.aer.com/) |
-! | |
-! --------------------------------------------------------------------------
-
-! Purpose: Create McICA stochastic arrays for cloud physical or optical properties.
-! Two options are possible:
-! 1) Input cloud physical properties: cloud fraction, ice and liquid water
-! paths, ice fraction, and particle sizes. Output will be stochastic
-! arrays of these variables. (inflag = 1)
-! 2) Input cloud optical properties directly: cloud optical depth, single
-! scattering albedo and asymmetry parameter. Output will be stochastic
-! arrays of these variables. (inflag = 0)
-
-! --------- Modules ----------
-
- use parkind, only : im => kind_im, rb => kind_rb
- use parrrsw, only : nbndsw, ngptsw
- use rrsw_con, only: grav
- use rrsw_wvn, only: ngb
- use rrsw_vsn
-
- implicit none
-
-! public interfaces/functions/subroutines
- public :: mcica_subcol_sw, generate_stochastic_clouds_sw
-
- contains
-
-!------------------------------------------------------------------
-! Public subroutines
-!------------------------------------------------------------------
-
-! mji - Add height needed for exponential-ranom cloud overlap method (icld=4)
- subroutine mcica_subcol_sw(iplon, ncol, nlay, icld, permuteseed, irng, play, hgt, &
- cldfrac, ciwp, clwp, cswp, rei, rel, res, tauc, ssac, asmc, fsfc, &
- cldfmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, &
- taucmcl, ssacmcl, asmcmcl, fsfcmcl)
-
-! ----- Input -----
-! Control
- integer(kind=im), intent(in) :: iplon ! column/longitude dimension
- integer(kind=im), intent(in) :: ncol ! number of columns
- integer(kind=im), intent(in) :: nlay ! number of model layers
- integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag
- integer(kind=im), intent(in) :: permuteseed ! if the cloud generator is called multiple times,
- ! permute the seed between each call;
- ! between calls for LW and SW, recommended
- ! permuteseed differs by 'ngpt'
- integer(kind=im), intent(inout) :: irng ! flag for random number generator
- ! 0 = kissvec
- ! 1 = Mersenne Twister
-
-! Atmosphere
- real(kind=rb), intent(in) :: play(:,:) ! layer pressures (mb)
- ! Dimensions: (ncol,nlay)
-! mji - Add height
- real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m)
- ! Dimensions: (ncol,nlay)
-! Atmosphere/clouds - cldprop
- real(kind=rb), intent(in) :: cldfrac(:,:) ! layer cloud fraction
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth
- ! Dimensions: (nbndsw,ncol,nlay)
- real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo (non-delta scaled)
- ! Dimensions: (nbndsw,ncol,nlay)
- real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter (non-delta scaled)
- ! Dimensions: (nbndsw,ncol,nlay)
- real(kind=rb), intent(in) :: fsfc(:,:,:) ! in-cloud forward scattering fraction (non-delta scaled)
- ! Dimensions: (nbndsw,ncol,nlay)
- real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow water path
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: rei(:,:) ! cloud ice particle size
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: rel(:,:) ! cloud liquid particle size
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: res(:,:) ! cloud snow particle size
- ! Dimensions: (ncol,nlay)
-
-! ----- Output -----
-! Atmosphere/clouds - cldprmc [mcica]
- real(kind=rb), intent(out) :: cldfmcl(:,:,:) ! cloud fraction [mcica]
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(out) :: ciwpmcl(:,:,:) ! in-cloud ice water path [mcica]
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(out) :: clwpmcl(:,:,:) ! in-cloud liquid water path [mcica]
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(out) :: cswpmcl(:,:,:) ! in-cloud snow water path [mcica]
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(out) :: relqmcl(:,:) ! liquid particle size (microns)
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(out) :: reicmcl(:,:) ! ice partcle size (microns)
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(out) :: resnmcl(:,:) ! snow partcle size (microns)
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(out) :: taucmcl(:,:,:) ! in-cloud optical depth [mcica]
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(out) :: ssacmcl(:,:,:) ! in-cloud single scattering albedo [mcica]
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(out) :: asmcmcl(:,:,:) ! in-cloud asymmetry parameter [mcica]
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(out) :: fsfcmcl(:,:,:) ! in-cloud forward scattering fraction [mcica]
- ! Dimensions: (ngptsw,ncol,nlay)
-
-! ----- Local -----
-
-! Stochastic cloud generator variables [mcica]
- integer(kind=im), parameter :: nsubcsw = ngptsw ! number of sub-columns (g-point intervals)
- integer(kind=im) :: ilev ! loop index
-
- real(kind=rb) :: pmid(ncol,nlay) ! layer pressures (Pa)
-! real(kind=rb) :: pdel(ncol,nlay) ! layer pressure thickness (Pa)
-! real(kind=rb) :: qi(ncol,nlay) ! ice water (specific humidity)
-! real(kind=rb) :: ql(ncol,nlay) ! liq water (specific humidity)
-
-
-! Return if clear sky
- if (icld.eq.0) return
-
-! NOTE: For GCM mode, permuteseed must be offset between LW and SW by at least number of subcolumns
-
-
-! Pass particle sizes to new arrays, no subcolumns for these properties yet
-! Convert pressures from mb to Pa
-
- reicmcl(:ncol,:nlay) = rei(:ncol,:nlay)
- relqmcl(:ncol,:nlay) = rel(:ncol,:nlay)
- resnmcl(:ncol,:nlay) = res(:ncol,:nlay)
- pmid(:ncol,:nlay) = play(:ncol,:nlay)*1.e2_rb
-
-! Convert input ice and liquid cloud water paths to specific humidity ice and liquid components
-
-! cwp = (q * pdel * 1000.) / gravit)
-! = (kg/kg * kg m-1 s-2 *1000.) / m s-2
-! = (g m-2)
-!
-! q = (cwp * gravit) / (pdel *1000.)
-! = (g m-2 * m s-2) / (kg m-1 s-2 * 1000.)
-! = kg/kg
-
-! do ilev = 1, nlay
-! qi(ilev) = (ciwp(ilev) * grav) / (pdel(ilev) * 1000._rb)
-! ql(ilev) = (clwp(ilev) * grav) / (pdel(ilev) * 1000._rb)
-! enddo
-
-! Generate the stochastic subcolumns of cloud optical properties for the shortwave;
- call generate_stochastic_clouds_sw (ncol, nlay, nsubcsw, icld, irng, pmid, hgt, cldfrac, clwp, ciwp, cswp, &
- tauc, ssac, asmc, fsfc, cldfmcl, clwpmcl, ciwpmcl, cswpmcl, &
- taucmcl, ssacmcl, asmcmcl, fsfcmcl, permuteseed)
-
- end subroutine mcica_subcol_sw
-
-
-!-------------------------------------------------------------------------------------------------
- subroutine generate_stochastic_clouds_sw(ncol, nlay, nsubcol, icld, irng, pmid, hgt, cld, clwp, ciwp, cswp, &
- tauc, ssac, asmc, fsfc, cld_stoch, clwp_stoch, ciwp_stoch, cswp_stoch, &
- tauc_stoch, ssac_stoch, asmc_stoch, fsfc_stoch, changeSeed)
-!-------------------------------------------------------------------------------------------------
-
- !----------------------------------------------------------------------------------------------------------------
- ! ---------------------
- ! Contact: Cecile Hannay (hannay@ucar.edu)
- !
- ! Original code: Based on Raisanen et al., QJRMS, 2004.
- !
- ! Modifications: Generalized for use with RRTMG and added Mersenne Twister as the default
- ! random number generator, which can be changed to the optional kissvec random number generator
- ! with flag 'irng'. Some extra functionality has been commented or removed.
- ! Michael J. Iacono, AER, Inc., February 2007
- !
- ! Given a profile of cloud fraction, cloud water and cloud ice, we produce a set of subcolumns.
- ! Each layer within each subcolumn is homogeneous, with cloud fraction equal to zero or one
- ! and uniform cloud liquid and cloud ice concentration.
- ! The ensemble as a whole reproduces the probability function of cloud liquid and ice within each layer
- ! and obeys an overlap assumption in the vertical.
- !
- ! Overlap assumption:
- ! The cloud are consistent with 4 overlap assumptions: random, maximum, maximum-random and exponential.
- ! The default option is maximum-random (option 3)
- ! The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap
- ! This is set with the variable "overlap"
- !mji - Exponential overlap option (overlap=4) has been deactivated in this version
- ! The exponential overlap uses also a length scale, Zo. (real, parameter :: Zo = 2500. )
- !
- ! Seed:
- ! If the stochastic cloud generator is called several times during the same timestep,
- ! one should change the seed between the call to insure that the subcolumns are different.
- ! This is done by changing the argument 'changeSeed'
- ! For example, if one wants to create a set of columns for the shortwave and another set for the longwave ,
- ! use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call
- !
- ! PDF assumption:
- ! We can use arbitrary complicated PDFS.
- ! In the present version, we produce homogeneuous clouds (the simplest case).
- ! Future developments include using the PDF scheme of Ben Johnson.
- !
- ! History file:
- ! Option to add diagnostics variables in the history file. (using FINCL in the namelist)
- ! nsubcol = number of subcolumns
- ! overlap = overlap type (1-3)
- ! Zo = length scale
- ! CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic)
- ! CLDLIQ_S = mean of the subcolumn cloud water
- ! CLDICE_S = mean of the subcolumn cloud ice
- !
- ! Note:
- ! Here: we force that the cloud condensate to be consistent with the cloud fraction
- ! i.e we only have cloud condensate when the cell is cloudy.
- ! In CAM: The cloud condensate and the cloud fraction are obtained from 2 different equations
- ! and the 2 quantities can be inconsistent (i.e. CAM can produce cloud fraction
- ! without cloud condensate or the opposite).
- !---------------------------------------------------------------------------------------------------------------
-
- use mcica_random_numbers
-! The Mersenne Twister random number engine
- use MersenneTwister, only: randomNumberSequence, &
- new_RandomNumberSequence, getRandomReal
-
- type(randomNumberSequence) :: randomNumbers
-
-! -- Arguments
-
- integer(kind=im), intent(in) :: ncol ! number of layers
- integer(kind=im), intent(in) :: nlay ! number of layers
- integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag
- integer(kind=im), intent(inout) :: irng ! flag for random number generator
- ! 0 = kissvec
- ! 1 = Mersenne Twister
- integer(kind=im), intent(in) :: nsubcol ! number of sub-columns (g-point intervals)
- integer(kind=im), optional, intent(in) :: changeSeed ! allows permuting seed
-
-! Column state (cloud fraction, cloud water, cloud ice) + variables needed to read physics state
- real(kind=rb), intent(in) :: pmid(:,:) ! layer pressure (Pa)
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m)
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: cld(:,:) ! cloud fraction
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path (g/m2)
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path (g/m2)
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow water path (g/m2)
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth (non-delta scaled)
- ! Dimensions: (nbndsw,ncol,nlay)
- real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo (non-delta scaled)
- ! Dimensions: (nbndsw,ncol,nlay)
- real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter (non-delta scaled)
- ! Dimensions: (nbndsw,ncol,nlay)
- real(kind=rb), intent(in) :: fsfc(:,:,:) ! in-cloud forward scattering fraction (non-delta scaled)
- ! Dimensions: (nbndsw,ncol,nlay)
-
- real(kind=rb), intent(out) :: cld_stoch(:,:,:) ! subcolumn cloud fraction
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(out) :: clwp_stoch(:,:,:) ! subcolumn in-cloud liquid water path
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(out) :: cswp_stoch(:,:,:) ! subcolumn in-cloud snow water path
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(out) :: ssac_stoch(:,:,:) ! subcolumn in-cloud single scattering albedo
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(out) :: asmc_stoch(:,:,:) ! subcolumn in-cloud asymmetry parameter
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(out) :: fsfc_stoch(:,:,:) ! subcolumn in-cloud forward scattering fraction
- ! Dimensions: (ngptsw,ncol,nlay)
-
-! -- Local variables
- real(kind=rb) :: cldf(ncol,nlay) ! cloud fraction
- ! Dimensions: (ncol,nlay)
-
-! Mean over the subcolumns (cloud fraction, cloud water , cloud ice) - inactive
-! real(kind=rb) :: mean_cld_stoch(ncol,nlay) ! cloud fraction
-! real(kind=rb) :: mean_clwp_stoch(ncol,nlay) ! cloud water
-! real(kind=rb) :: mean_ciwp_stoch(ncol,nlay) ! cloud ice
-! real(kind=rb) :: mean_tauc_stoch(ncol,nlay) ! cloud optical depth
-! real(kind=rb) :: mean_ssac_stoch(ncol,nlay) ! cloud single scattering albedo
-! real(kind=rb) :: mean_asmc_stoch(ncol,nlay) ! cloud asymmetry parameter
-! real(kind=rb) :: mean_fsfc_stoch(ncol,nlay) ! cloud forward scattering fraction
-
-! Set overlap
- integer(kind=im) :: overlap ! 1 = random overlap, 2 = maximum-random,
- ! 3 = maximum overlap, 4 = exponential,
- ! 5 = exponential-random
- real(kind=rb), parameter :: Zo = 2500._rb ! length scale (m)
- real(kind=rb), dimension(ncol,nlay) :: alpha ! overlap parameter
-
-! Constants (min value for cloud fraction and cloud water and ice)
- real(kind=rb), parameter :: cldmin = 1.0e-20_rb ! min cloud fraction
-! real(kind=rb), parameter :: qmin = 1.0e-10_rb ! min cloud water and cloud ice (not used)
-
-! Variables related to random number and seed
- real(kind=rb), dimension(nsubcol, ncol, nlay) :: CDF, CDF2 ! random numbers
- integer(kind=im), dimension(ncol) :: seed1, seed2, seed3, seed4 ! seed to create random number
- real(kind=rb), dimension(ncol) :: rand_num ! random number (kissvec)
- integer(kind=im) :: iseed ! seed to create random number (Mersenne Twister)
- real(kind=rb) :: rand_num_mt ! random number (Mersenne Twister)
-
-! Flag to identify cloud fraction in subcolumns
- logical, dimension(nsubcol, ncol, nlay) :: isCloudy ! flag that says whether a gridbox is cloudy
-
-! Indices
- integer(kind=im) :: ilev, isubcol, i, n, ngbm ! indices
-
-!------------------------------------------------------------------------------------------
-
-! Check that irng is in bounds; if not, set to default
- if (irng .ne. 0) irng = 1
-
-! Pass input cloud overlap setting to local variable
- overlap = icld
-
-! Ensure that cloud fractions are in bounds
- do ilev = 1, nlay
- do i = 1, ncol
- cldf(i,ilev) = cld(i,ilev)
- if (cldf(i,ilev) < cldmin) then
- cldf(i,ilev) = 0._rb
- endif
- enddo
- enddo
-
-! ----- Create seed --------
-
-! Advance randum number generator by changeseed values
- if (irng.eq.0) then
-! For kissvec, create a seed that depends on the state of the columns. Maybe not the best way, but it works.
-! Must use pmid from bottom four layers.
- do i=1,ncol
- if (pmid(i,1).lt.pmid(i,2)) then
- stop 'MCICA_SUBCOL: KISSVEC SEED GENERATOR REQUIRES PMID FROM BOTTOM FOUR LAYERS.'
- endif
- seed1(i) = (pmid(i,1) - int(pmid(i,1))) * 1000000000_im
- seed2(i) = (pmid(i,2) - int(pmid(i,2))) * 1000000000_im
- seed3(i) = (pmid(i,3) - int(pmid(i,3))) * 1000000000_im
- seed4(i) = (pmid(i,4) - int(pmid(i,4))) * 1000000000_im
- enddo
- do i=1,changeSeed
- call kissvec(seed1, seed2, seed3, seed4, rand_num)
- enddo
- elseif (irng.eq.1) then
- randomNumbers = new_RandomNumberSequence(seed = changeSeed)
- endif
-
-
-! ------ Apply overlap assumption --------
-
-! generate the random numbers
-
- select case (overlap)
-
- case(1)
-! Random overlap
-! i) pick a random value at every level
-
- if (irng.eq.0) then
- do isubcol = 1,nsubcol
- do ilev = 1,nlay
- call kissvec(seed1, seed2, seed3, seed4, rand_num)
- CDF(isubcol,:,ilev) = rand_num
- enddo
- enddo
- elseif (irng.eq.1) then
- do isubcol = 1, nsubcol
- do i = 1, ncol
- do ilev = 1, nlay
- rand_num_mt = getRandomReal(randomNumbers)
- CDF(isubcol,i,ilev) = rand_num_mt
- enddo
- enddo
- enddo
- endif
-
- case(2)
-! Maximum-Random overlap
-! i) pick a random number for top layer.
-! ii) walk down the column:
-! - if the layer above is cloudy, we use the same random number than in the layer above
-! - if the layer above is clear, we use a new random number
-
- if (irng.eq.0) then
- do isubcol = 1,nsubcol
- do ilev = 1,nlay
- call kissvec(seed1, seed2, seed3, seed4, rand_num)
- CDF(isubcol,:,ilev) = rand_num
- enddo
- enddo
- elseif (irng.eq.1) then
- do isubcol = 1, nsubcol
- do i = 1, ncol
- do ilev = 1, nlay
- rand_num_mt = getRandomReal(randomNumbers)
- CDF(isubcol,i,ilev) = rand_num_mt
- enddo
- enddo
- enddo
- endif
-
- do ilev = 2,nlay
- do i = 1, ncol
- do isubcol = 1, nsubcol
- if (CDF(isubcol, i, ilev-1) > 1._rb - cldf(i,ilev-1) ) then
- CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev-1)
- else
- CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev) * (1._rb - cldf(i,ilev-1))
- endif
- enddo
- enddo
- enddo
-
- case(3)
-! Maximum overlap
-! i) pick same random numebr at every level
-
- if (irng.eq.0) then
- do isubcol = 1,nsubcol
- call kissvec(seed1, seed2, seed3, seed4, rand_num)
- do ilev = 1,nlay
- CDF(isubcol,:,ilev) = rand_num
- enddo
- enddo
- elseif (irng.eq.1) then
- do isubcol = 1, nsubcol
- do i = 1, ncol
- rand_num_mt = getRandomReal(randomNumbers)
- do ilev = 1, nlay
- CDF(isubcol,i,ilev) = rand_num_mt
- enddo
- enddo
- enddo
- endif
-
-! mji - Activate exponential cloud overlap option
- case(4)
- ! Exponential overlap: weighting between maximum and random overlap increases with the distance.
- ! The random numbers for exponential overlap verify:
- ! j=1 RAN(j)=RND1
- ! j>1 if RND1 < alpha(j,j-1) => RAN(j) = RAN(j-1)
- ! RAN(j) = RND2
- ! alpha is obtained from the equation
- ! alpha = exp(-(Z(j)-Z(j-1))/Zo) where Zo is a characteristic length scale
-
- ! compute alpha
- do i = 1, ncol
- alpha(i, 1) = 0._rb
- do ilev = 2,nlay
- alpha(i, ilev) = exp( -( hgt (i, ilev) - hgt (i, ilev-1)) / Zo)
- enddo
- enddo
-
- ! generate 2 streams of random numbers
- if (irng.eq.0) then
- do isubcol = 1,nsubcol
- do ilev = 1,nlay
- call kissvec(seed1, seed2, seed3, seed4, rand_num)
- CDF(isubcol, :, ilev) = rand_num
- call kissvec(seed1, seed2, seed3, seed4, rand_num)
- CDF2(isubcol, :, ilev) = rand_num
- enddo
- enddo
- elseif (irng.eq.1) then
- do isubcol = 1, nsubcol
- do i = 1, ncol
- do ilev = 1, nlay
- rand_num_mt = getRandomReal(randomNumbers)
- CDF(isubcol,i,ilev) = rand_num_mt
- rand_num_mt = getRandomReal(randomNumbers)
- CDF2(isubcol,i,ilev) = rand_num_mt
- enddo
- enddo
- enddo
- endif
-
- ! generate random numbers
- do ilev = 2,nlay
- where (CDF2(:, :, ilev) < spread(alpha (:,ilev), dim=1, nCopies=nsubcol) )
- CDF(:,:,ilev) = CDF(:,:,ilev-1)
- end where
- end do
-
-! mji - Exponential-random cloud overlap option
- case(5)
- ! Exponential-random overlap:
- call wrf_error_fatal("Cloud Overlap case 5: ER has not yet been implemented. Stopping...")
-
- end select
-
-
-! -- generate subcolumns for homogeneous clouds -----
- do ilev = 1, nlay
- isCloudy(:,:,ilev) = (CDF(:,:,ilev) >= 1._rb - spread(cldf(:,ilev), dim=1, nCopies=nsubcol) )
- enddo
-
-! where the subcolumn is cloudy, the subcolumn cloud fraction is 1;
-! where the subcolumn is not cloudy, the subcolumn cloud fraction is 0;
-! where there is a cloud, define the subcolumn cloud properties,
-! otherwise set these to zero
-
- ngbm = ngb(1) - 1
- do ilev = 1,nlay
- do i = 1, ncol
- do isubcol = 1, nsubcol
- if ( iscloudy(isubcol,i,ilev) ) then
- cld_stoch(isubcol,i,ilev) = 1._rb
- clwp_stoch(isubcol,i,ilev) = clwp(i,ilev)
- ciwp_stoch(isubcol,i,ilev) = ciwp(i,ilev)
- cswp_stoch(isubcol,i,ilev) = cswp(i,ilev)
- n = ngb(isubcol) - ngbm
- tauc_stoch(isubcol,i,ilev) = tauc(n,i,ilev)
- ssac_stoch(isubcol,i,ilev) = ssac(n,i,ilev)
- asmc_stoch(isubcol,i,ilev) = asmc(n,i,ilev)
- fsfc_stoch(isubcol,i,ilev) = fsfc(n,i,ilev)
- else
- cld_stoch(isubcol,i,ilev) = 0._rb
- clwp_stoch(isubcol,i,ilev) = 0._rb
- ciwp_stoch(isubcol,i,ilev) = 0._rb
- cswp_stoch(isubcol,i,ilev) = 0._rb
- tauc_stoch(isubcol,i,ilev) = 0._rb
- ssac_stoch(isubcol,i,ilev) = 1._rb
- asmc_stoch(isubcol,i,ilev) = 0._rb
- fsfc_stoch(isubcol,i,ilev) = 0._rb
- endif
- enddo
- enddo
- enddo
-
-! -- compute the means of the subcolumns ---
-! mean_cld_stoch(:,:) = 0._rb
-! mean_clwp_stoch(:,:) = 0._rb
-! mean_ciwp_stoch(:,:) = 0._rb
-! mean_tauc_stoch(:,:) = 0._rb
-! mean_ssac_stoch(:,:) = 0._rb
-! mean_asmc_stoch(:,:) = 0._rb
-! mean_fsfc_stoch(:,:) = 0._rb
-! do i = 1, nsubcol
-! mean_cld_stoch(:,:) = cld_stoch(i,:,:) + mean_cld_stoch(:,:)
-! mean_clwp_stoch(:,:) = clwp_stoch( i,:,:) + mean_clwp_stoch(:,:)
-! mean_ciwp_stoch(:,:) = ciwp_stoch( i,:,:) + mean_ciwp_stoch(:,:)
-! mean_tauc_stoch(:,:) = tauc_stoch( i,:,:) + mean_tauc_stoch(:,:)
-! mean_ssac_stoch(:,:) = ssac_stoch( i,:,:) + mean_ssac_stoch(:,:)
-! mean_asmc_stoch(:,:) = asmc_stoch( i,:,:) + mean_asmc_stoch(:,:)
-! mean_fsfc_stoch(:,:) = fsfc_stoch( i,:,:) + mean_fsfc_stoch(:,:)
-! end do
-! mean_cld_stoch(:,:) = mean_cld_stoch(:,:) / nsubcol
-! mean_clwp_stoch(:,:) = mean_clwp_stoch(:,:) / nsubcol
-! mean_ciwp_stoch(:,:) = mean_ciwp_stoch(:,:) / nsubcol
-! mean_tauc_stoch(:,:) = mean_tauc_stoch(:,:) / nsubcol
-! mean_ssac_stoch(:,:) = mean_ssac_stoch(:,:) / nsubcol
-! mean_asmc_stoch(:,:) = mean_asmc_stoch(:,:) / nsubcol
-! mean_fsfc_stoch(:,:) = mean_fsfc_stoch(:,:) / nsubcol
-
- end subroutine generate_stochastic_clouds_sw
-
-
-!--------------------------------------------------------------------------------------------------
- subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr)
-!--------------------------------------------------------------------------------------------------
-
-! public domain code
-! made available from http://www.fortran.com/
-! downloaded by pjr on 03/16/04 for NCAR CAM
-! converted to vector form, functions inlined by pjr,mvr on 05/10/2004
-
-! The KISS (Keep It Simple Stupid) random number generator. Combines:
-! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32.
-! (2) A 3-shift shift-register generator, period 2^32-1,
-! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59
-! Overall period>2^123;
-!
- real(kind=rb), dimension(:), intent(inout) :: ran_arr
- integer(kind=im), dimension(:), intent(inout) :: seed1,seed2,seed3,seed4
- integer(kind=im) :: i,sz,kiss
- integer(kind=im) :: m, k, n
-
-! inline function
- m(k, n) = ieor (k, ishft (k, n) )
-
- sz = size(ran_arr)
- do i = 1, sz
- seed1(i) = 69069_im * seed1(i) + 1327217885_im
- seed2(i) = m (m (m (seed2(i), 13_im), - 17_im), 5_im)
- seed3(i) = 18000_im * iand (seed3(i), 65535_im) + ishft (seed3(i), - 16_im)
- seed4(i) = 30903_im * iand (seed4(i), 65535_im) + ishft (seed4(i), - 16_im)
- kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16_im) + seed4(i)
- ran_arr(i) = kiss*2.328306e-10_rb + 0.5_rb
- end do
-
- end subroutine kissvec
-
- end module mcica_subcol_gen_sw
-
-! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
-! author: $Author: trn $
-! revision: $Revision: 1.3 $
-! created: $Date: 2009/04/16 19:54:22 $
-
- module rrtmg_sw_cldprmc
-
-! --------------------------------------------------------------------------
-! | |
-! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
-! | This software may be used, copied, or redistributed as long as it is |
-! | not sold and this copyright notice is reproduced on each copy made. |
-! | This model is provided as is without any express or implied warranties. |
-! | (http://www.rtweb.aer.com/) |
-! | |
-! --------------------------------------------------------------------------
-
-! ------- Modules -------
-
- use parkind, only : im => kind_im, rb => kind_rb
- use parrrsw, only : ngptsw, jpband, jpb1, jpb2
- use rrsw_cld, only : extliq1, ssaliq1, asyliq1, &
- extice2, ssaice2, asyice2, &
- extice3, ssaice3, asyice3, fdlice3, &
- abari, bbari, cbari, dbari, ebari, fbari
- use rrsw_wvn, only : wavenum1, wavenum2, ngb
- use rrsw_vsn, only : hvrclc, hnamclc
-
- implicit none
-
- contains
-
-! ----------------------------------------------------------------------------
- subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, &
- ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, &
- taormc, taucmc, ssacmc, asmcmc, fsfcmc)
-! ----------------------------------------------------------------------------
-
-! Purpose: Compute the cloud optical properties for each cloudy layer
-! and g-point interval for use by the McICA method.
-! Note: Only inflag = 0 and inflag=2/liqflag=1/iceflag=2,3 are available;
-! (Hu & Stamnes, Key, and Fu) are implemented.
-
-! ------- Input -------
-
- integer(kind=im), intent(in) :: nlayers ! total number of layers
- integer(kind=im), intent(in) :: inflag ! see definitions
- integer(kind=im), intent(in) :: iceflag ! see definitions
- integer(kind=im), intent(in) :: liqflag ! see definitions
-
- real(kind=rb), intent(in) :: cldfmc(:,:) ! cloud fraction [mcica]
- ! Dimensions: (ngptsw,nlayers)
- real(kind=rb), intent(in) :: ciwpmc(:,:) ! cloud ice water path [mcica]
- ! Dimensions: (ngptsw,nlayers)
- real(kind=rb), intent(in) :: clwpmc(:,:) ! cloud liquid water path [mcica]
- ! Dimensions: (ngptsw,nlayers)
- real(kind=rb), intent(in) :: cswpmc(:,:) ! cloud snow water path [mcica]
- ! Dimensions: (ngptsw,nlayers)
- real(kind=rb), intent(in) :: resnmc(:) ! cloud snow particle effective radius (microns)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: relqmc(:) ! cloud liquid particle effective radius (microns)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: reicmc(:) ! cloud ice particle effective radius (microns)
- ! Dimensions: (nlayers)
- ! specific definition of reicmc depends on setting of iceflag:
- ! iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
- ! r_ec range is limited to 13.0 to 130.0 microns
- ! iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
- ! r_k range is limited to 5.0 to 131.0 microns
- ! iceflag = 3: generalized effective size, dge, (Fu, 1996),
- ! dge range is limited to 5.0 to 140.0 microns
- ! [dge = 1.0315 * r_ec]
- real(kind=rb), intent(in) :: fsfcmc(:,:) ! cloud forward scattering fraction
- ! Dimensions: (ngptsw,nlayers)
-
-! ------- Output -------
-
- real(kind=rb), intent(inout) :: taucmc(:,:) ! cloud optical depth (delta scaled)
- ! Dimensions: (ngptsw,nlayers)
- real(kind=rb), intent(inout) :: ssacmc(:,:) ! single scattering albedo (delta scaled)
- ! Dimensions: (ngptsw,nlayers)
- real(kind=rb), intent(inout) :: asmcmc(:,:) ! asymmetry parameter (delta scaled)
- ! Dimensions: (ngptsw,nlayers)
- real(kind=rb), intent(out) :: taormc(:,:) ! cloud optical depth (non-delta scaled)
- ! Dimensions: (ngptsw,nlayers)
-
-! ------- Local -------
-
-! integer(kind=im) :: ncbands
- integer(kind=im) :: ib, lay, istr, index, icx, ig
-
- real(kind=rb), parameter :: eps = 1.e-06_rb ! epsilon
- real(kind=rb), parameter :: cldmin = 1.e-20_rb ! minimum value for cloud quantities
- real(kind=rb) :: cwp ! total cloud water path
- real(kind=rb) :: radliq ! cloud liquid droplet radius (microns)
- real(kind=rb) :: radice ! cloud ice effective size (microns)
- real(kind=rb) :: radsno ! cloud snow effective size (microns)
- real(kind=rb) :: factor
- real(kind=rb) :: fint
-
- real(kind=rb) :: taucldorig_a, taucloud_a, ssacloud_a, ffp, ffp1, ffpssa
- real(kind=rb) :: tauiceorig, scatice, ssaice, tauice, tauliqorig, scatliq, ssaliq, tauliq
- real(kind=rb) :: tausnoorig, scatsno, ssasno, tausno
-
- real(kind=rb) :: fdelta(ngptsw)
- real(kind=rb) :: extcoice(ngptsw), gice(ngptsw)
- real(kind=rb) :: ssacoice(ngptsw), forwice(ngptsw)
- real(kind=rb) :: extcoliq(ngptsw), gliq(ngptsw)
- real(kind=rb) :: ssacoliq(ngptsw), forwliq(ngptsw)
- real(kind=rb) :: extcosno(ngptsw), gsno(ngptsw)
- real(kind=rb) :: ssacosno(ngptsw), forwsno(ngptsw)
-
- CHARACTER*80 errmess
-
-! Initialize
-
-!jm not thread safe hvrclc = '$Revision: 1.3 $'
-
-! Some of these initializations are done elsewhere
- do lay = 1, nlayers
- do ig = 1, ngptsw
- taormc(ig,lay) = taucmc(ig,lay)
-! taucmc(ig,lay) = 0.0_rb
-! ssacmc(ig,lay) = 1.0_rb
-! asmcmc(ig,lay) = 0.0_rb
- enddo
- enddo
-
-! Main layer loop
- do lay = 1, nlayers
-
-! Main g-point interval loop
- do ig = 1, ngptsw
- cwp = ciwpmc(ig,lay) + clwpmc(ig,lay) + cswpmc(ig,lay)
-
- if (cldfmc(ig,lay) .ge. cldmin .and. &
- (cwp .ge. cldmin .or. taucmc(ig,lay) .ge. cldmin)) then
-
-! (inflag=0): Cloud optical properties input directly
- if (inflag .eq. 0) then
-! Cloud optical properties already defined in taucmc, ssacmc, asmcmc are unscaled;
-! Apply delta-M scaling here (using Henyey-Greenstein approximation)
- taucldorig_a = taucmc(ig,lay)
- ffp = fsfcmc(ig,lay)
- ffp1 = 1.0_rb - ffp
- ffpssa = 1.0_rb - ffp * ssacmc(ig,lay)
- ssacloud_a = ffp1 * ssacmc(ig,lay) / ffpssa
- taucloud_a = ffpssa * taucldorig_a
-
- taormc(ig,lay) = taucldorig_a
- ssacmc(ig,lay) = ssacloud_a
- taucmc(ig,lay) = taucloud_a
- asmcmc(ig,lay) = (asmcmc(ig,lay) - ffp) / (ffp1)
-
- elseif (inflag .eq. 1) then
- stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA'
-
-! (inflag=2): Separate treatement of ice clouds and water clouds.
- elseif (inflag .ge. 2) then
- radice = reicmc(lay)
-
-! Calculation of absorption coefficients due to ice clouds.
- if ((ciwpmc(ig,lay)+cswpmc(ig,lay)) .eq. 0.0_rb) then
- extcoice(ig) = 0.0_rb
- ssacoice(ig) = 0.0_rb
- gice(ig) = 0.0_rb
- forwice(ig) = 0.0_rb
-
- extcosno(ig) = 0.0_rb
- ssacosno(ig) = 0.0_rb
- gsno(ig) = 0.0_rb
- forwsno(ig) = 0.0_rb
-
-! (iceflag = 1):
-! Note: This option uses Ebert and Curry approach for all particle sizes similar to
-! CAM3 implementation, though this is somewhat unjustified for large ice particles
- elseif (iceflag .eq. 1) then
- ib = ngb(ig)
- if (wavenum2(ib) .gt. 1.43e04_rb) then
- icx = 1
- elseif (wavenum2(ib) .gt. 7.7e03_rb) then
- icx = 2
- elseif (wavenum2(ib) .gt. 5.3e03_rb) then
- icx = 3
- elseif (wavenum2(ib) .gt. 4.0e03_rb) then
- icx = 4
- elseif (wavenum2(ib) .ge. 2.5e03_rb) then
- icx = 5
- endif
- extcoice(ig) = (abari(icx) + bbari(icx)/radice)
- ssacoice(ig) = 1._rb - cbari(icx) - dbari(icx) * radice
- gice(ig) = ebari(icx) + fbari(icx) * radice
-! Check to ensure upper limit of gice is within physical limits for large particles
- if (gice(ig).ge.1._rb) gice(ig) = 1._rb - eps
- forwice(ig) = gice(ig)*gice(ig)
-! Check to ensure all calculated quantities are within physical limits.
- if (extcoice(ig) .lt. 0.0_rb) stop 'ICE EXTINCTION LESS THAN 0.0'
- if (ssacoice(ig) .gt. 1.0_rb) stop 'ICE SSA GRTR THAN 1.0'
- if (ssacoice(ig) .lt. 0.0_rb) stop 'ICE SSA LESS THAN 0.0'
- if (gice(ig) .gt. 1.0_rb) stop 'ICE ASYM GRTR THAN 1.0'
- if (gice(ig) .lt. 0.0_rb) stop 'ICE ASYM LESS THAN 0.0'
-
-! For iceflag=2 option, ice particle effective radius is limited to 5.0 to 131.0 microns
-
- elseif (iceflag .eq. 2) then
- if (radice .lt. 5.0_rb .or. radice .gt. 131.0_rb) stop 'ICE RADIUS OUT OF BOUNDS'
- factor = (radice - 2._rb)/3._rb
- index = int(factor)
- if (index .eq. 43) index = 42
- fint = factor - float(index)
- ib = ngb(ig)
- extcoice(ig) = extice2(index,ib) + fint * &
- (extice2(index+1,ib) - extice2(index,ib))
- ssacoice(ig) = ssaice2(index,ib) + fint * &
- (ssaice2(index+1,ib) - ssaice2(index,ib))
- gice(ig) = asyice2(index,ib) + fint * &
- (asyice2(index+1,ib) - asyice2(index,ib))
- forwice(ig) = gice(ig)*gice(ig)
-! Check to ensure all calculated quantities are within physical limits.
- if (extcoice(ig) .lt. 0.0_rb) stop 'ICE EXTINCTION LESS THAN 0.0'
- if (ssacoice(ig) .gt. 1.0_rb) stop 'ICE SSA GRTR THAN 1.0'
- if (ssacoice(ig) .lt. 0.0_rb) stop 'ICE SSA LESS THAN 0.0'
- if (gice(ig) .gt. 1.0_rb) stop 'ICE ASYM GRTR THAN 1.0'
- if (gice(ig) .lt. 0.0_rb) stop 'ICE ASYM LESS THAN 0.0'
-
-! For iceflag=3 option, ice particle generalized effective size is limited to 5.0 to 140.0 microns
-
- elseif (iceflag .ge. 3) then
- if (radice .lt. 5.0_rb .or. radice .gt. 140.0_rb) then
- write(errmess,'(A,i5,i5,f8.2,f8.2)' ) &
- 'ERROR: ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' &
- ,ig, lay, ciwpmc(ig,lay), radice
- call wrf_error_fatal(errmess)
- end if
- factor = (radice - 2._rb)/3._rb
- index = int(factor)
- if (index .eq. 46) index = 45
- fint = factor - float(index)
- ib = ngb(ig)
- extcoice(ig) = extice3(index,ib) + fint * &
- (extice3(index+1,ib) - extice3(index,ib))
- ssacoice(ig) = ssaice3(index,ib) + fint * &
- (ssaice3(index+1,ib) - ssaice3(index,ib))
- gice(ig) = asyice3(index,ib) + fint * &
- (asyice3(index+1,ib) - asyice3(index,ib))
- fdelta(ig) = fdlice3(index,ib) + fint * &
- (fdlice3(index+1,ib) - fdlice3(index,ib))
- if (fdelta(ig) .lt. 0.0_rb) then
- write(errmess, *) 'FDELTA LESS THAN 0.0'
- call wrf_error_fatal(errmess)
- end if
- if (fdelta(ig) .gt. 1.0_rb) then
- write(errmess, *) 'FDELTA GT THAN 1.0'
- call wrf_error_fatal(errmess)
- end if
- forwice(ig) = fdelta(ig) + 0.5_rb / ssacoice(ig)
-! See Fu 1996 p. 2067
- if (forwice(ig) .gt. gice(ig)) forwice(ig) = gice(ig)
-! Check to ensure all calculated quantities are within physical limits.
- if (extcoice(ig) .lt. 0.0_rb) stop 'ICE EXTINCTION LESS THAN 0.0'
- if (ssacoice(ig) .gt. 1.0_rb) stop 'ICE SSA GRTR THAN 1.0'
- if (ssacoice(ig) .lt. 0.0_rb) stop 'ICE SSA LESS THAN 0.0'
- if (gice(ig) .gt. 1.0_rb) stop 'ICE ASYM GRTR THAN 1.0'
- if (gice(ig) .lt. 0.0_rb) stop 'ICE ASYM LESS THAN 0.0'
-
- endif
-
-!!!!!!!!!!!!!!!!!! Mukul !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!! INSERT THE EQUIVALENT SNOW VARIABLE CODE HERE
-!!!! Although far from perfect, the snow will utilize the
-!!!! same lookup table constants as cloud ice. Changes
-!!!! to those constants for larger particle snow would be
-!!!! an improvement.
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- if (cswpmc(ig,lay).gt.0.0_rb .and. iceflag .eq. 5) then
- radsno = resnmc(lay)
- if (radsno .lt. 5.0_rb .or. radsno .gt. 140.0_rb) then
- write(errmess,'(A,i5,i5,f8.2,f8.2)' ) &
- 'ERROR: SNOW GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' &
- ,ig, lay, cswpmc(ig,lay), radsno
- call wrf_error_fatal(errmess)
- end if
- factor = (radsno - 2._rb)/3._rb
- index = int(factor)
- if (index .eq. 46) index = 45
- fint = factor - float(index)
- ib = ngb(ig)
- extcosno(ig) = extice3(index,ib) + fint * &
- (extice3(index+1,ib) - extice3(index,ib))
- ssacosno(ig) = ssaice3(index,ib) + fint * &
- (ssaice3(index+1,ib) - ssaice3(index,ib))
- gsno(ig) = asyice3(index,ib) + fint * &
- (asyice3(index+1,ib) - asyice3(index,ib))
- fdelta(ig) = fdlice3(index,ib) + fint * &
- (fdlice3(index+1,ib) - fdlice3(index,ib))
- if (fdelta(ig) .lt. 0.0_rb) then
- write(errmess, *) 'FDELTA LESS THAN 0.0'
- call wrf_error_fatal(errmess)
- end if
- if (fdelta(ig) .gt. 1.0_rb) then
- write(errmess, *) 'FDELTA GT THAN 1.0'
- call wrf_error_fatal(errmess)
- end if
- forwsno(ig) = fdelta(ig) + 0.5_rb / ssacosno(ig)
-! See Fu 1996 p. 2067
- if (forwsno(ig) .gt. gsno(ig)) forwsno(ig) = gsno(ig)
-! Check to ensure all calculated quantities are within physical limits.
- if (extcosno(ig) .lt. 0.0_rb) then
- write(errmess, *) 'SNOW EXTINCTION LESS THAN 0.0'
- call wrf_error_fatal(errmess)
- end if
- if (ssacosno(ig) .gt. 1.0_rb) then
- write(errmess, *) 'SNOW SSA GRTR THAN 1.0'
- call wrf_error_fatal(errmess)
- end if
- if (ssacosno(ig) .lt. 0.0_rb) then
- write(errmess, *) 'SNOW SSA LESS THAN 0.0'
- call wrf_error_fatal(errmess)
- end if
- if (gsno(ig) .gt. 1.0_rb) then
- write(errmess, *) 'SNOW ASYM GRTR THAN 1.0'
- call wrf_error_fatal(errmess)
- end if
- if (gsno(ig) .lt. 0.0_rb) then
- write(errmess, *) 'SNOW ASYM LESS THAN 0.0'
- call wrf_error_fatal(errmess)
- end if
- else
- extcosno(ig) = 0.0_rb
- ssacosno(ig) = 0.0_rb
- gsno(ig) = 0.0_rb
- forwsno(ig) = 0.0_rb
- endif
-
-
-! Calculation of absorption coefficients due to water clouds.
- if (clwpmc(ig,lay) .eq. 0.0_rb) then
- extcoliq(ig) = 0.0_rb
- ssacoliq(ig) = 0.0_rb
- gliq(ig) = 0.0_rb
- forwliq(ig) = 0.0_rb
-
- elseif (liqflag .eq. 1) then
- radliq = relqmc(lay)
- if (radliq .lt. 1.5_rb .or. radliq .gt. 60._rb) stop &
- 'liquid effective radius out of bounds'
- index = int(radliq - 1.5_rb)
- if (index .eq. 0) index = 1
- if (index .eq. 58) index = 57
- fint = radliq - 1.5_rb - float(index)
- ib = ngb(ig)
- extcoliq(ig) = extliq1(index,ib) + fint * &
- (extliq1(index+1,ib) - extliq1(index,ib))
- ssacoliq(ig) = ssaliq1(index,ib) + fint * &
- (ssaliq1(index+1,ib) - ssaliq1(index,ib))
- if (fint .lt. 0._rb .and. ssacoliq(ig) .gt. 1._rb) &
- ssacoliq(ig) = ssaliq1(index,ib)
- gliq(ig) = asyliq1(index,ib) + fint * &
- (asyliq1(index+1,ib) - asyliq1(index,ib))
- forwliq(ig) = gliq(ig)*gliq(ig)
-! Check to ensure all calculated quantities are within physical limits.
- if (extcoliq(ig) .lt. 0.0_rb) stop 'LIQUID EXTINCTION LESS THAN 0.0'
- if (ssacoliq(ig) .gt. 1.0_rb) stop 'LIQUID SSA GRTR THAN 1.0'
- if (ssacoliq(ig) .lt. 0.0_rb) stop 'LIQUID SSA LESS THAN 0.0'
- if (gliq(ig) .gt. 1.0_rb) stop 'LIQUID ASYM GRTR THAN 1.0'
- if (gliq(ig) .lt. 0.0_rb) stop 'LIQUID ASYM LESS THAN 0.0'
- endif
-
-
- if (iceflag .lt. 5) then
- tauliqorig = clwpmc(ig,lay) * extcoliq(ig)
- tauiceorig = ciwpmc(ig,lay) * extcoice(ig)
- taormc(ig,lay) = tauliqorig + tauiceorig
-
- ssaliq = ssacoliq(ig) * (1._rb - forwliq(ig)) / &
- (1._rb - forwliq(ig) * ssacoliq(ig))
- tauliq = (1._rb - forwliq(ig) * ssacoliq(ig)) * tauliqorig
- ssaice = ssacoice(ig) * (1._rb - forwice(ig)) / &
- (1._rb - forwice(ig) * ssacoice(ig))
- tauice = (1._rb - forwice(ig) * ssacoice(ig)) * tauiceorig
- scatliq = ssaliq * tauliq
- scatice = ssaice * tauice
- scatsno = 0.0_rb
- taucmc(ig,lay) = tauliq + tauice
- else
- tauliqorig = clwpmc(ig,lay) * extcoliq(ig)
- tauiceorig = ciwpmc(ig,lay) * extcoice(ig)
- tausnoorig = cswpmc(ig,lay) * extcosno(ig)
- taormc(ig,lay) = tauliqorig + tauiceorig + tausnoorig
-
- ssaliq = ssacoliq(ig) * (1._rb - forwliq(ig)) / &
- (1._rb - forwliq(ig) * ssacoliq(ig))
- tauliq = (1._rb - forwliq(ig) * ssacoliq(ig)) * tauliqorig
- ssaice = ssacoice(ig) * (1._rb - forwice(ig)) / &
- (1._rb - forwice(ig) * ssacoice(ig))
- tauice = (1._rb - forwice(ig) * ssacoice(ig)) * tauiceorig
- ssasno = ssacosno(ig) * (1._rb - forwsno(ig)) / &
- (1._rb - forwsno(ig) * ssacosno(ig))
- tausno = (1._rb - forwsno(ig) * ssacosno(ig)) * tausnoorig
- scatliq = ssaliq * tauliq
- scatice = ssaice * tauice
- scatsno = ssasno * tausno
- taucmc(ig,lay) = tauliq + tauice + tausno
- endif
-
-! Ensure non-zero taucmc and scatice
- if(taucmc(ig,lay).eq.0.) taucmc(ig,lay) = cldmin
- if(scatice.eq.0.) scatice = cldmin
- if(scatsno.eq.0.) scatsno = cldmin
-
- if (iceflag .lt. 5) then
- ssacmc(ig,lay) = (scatliq + scatice) / taucmc(ig,lay)
- else
- ssacmc(ig,lay) = (scatliq + scatice + scatsno) / taucmc(ig,lay)
- endif
-
- if (iceflag .eq. 3 .or. iceflag.eq.4) then
-! In accordance with the 1996 Fu paper, equation A.3,
-! the moments for ice were calculated depending on whether using spheres
-! or hexagonal ice crystals.
-! Set asymetry parameter to first moment (istr=1)
- istr = 1
- asmcmc(ig,lay) = (1.0_rb/(scatliq+scatice))* &
- (scatliq*(gliq(ig)**istr - forwliq(ig)) / &
- (1.0_rb - forwliq(ig)) + scatice * ((gice(ig)-forwice(ig))/ &
- (1.0_rb - forwice(ig)))**istr)
- elseif (iceflag .eq. 5) then
- istr = 1
- asmcmc(ig,lay) = (1.0_rb/(scatliq+scatice+scatsno)) &
- * (scatliq*(gliq(ig)**istr - forwliq(ig))/(1.0_rb - forwliq(ig)) &
- + scatice * ((gice(ig)-forwice(ig))/(1.0_rb - forwice(ig))) &
- + scatsno * ((gsno(ig)-forwsno(ig))/(1.0_rb - forwsno(ig)))**istr)
-
- else
-! This code is the standard method for delta-m scaling.
-! Set asymetry parameter to first moment (istr=1)
- istr = 1
- asmcmc(ig,lay) = (scatliq * &
- (gliq(ig)**istr - forwliq(ig)) / &
- (1.0_rb - forwliq(ig)) + scatice * (gice(ig)**istr - forwice(ig)) / &
- (1.0_rb - forwice(ig)))/(scatliq + scatice)
- endif
-
- endif
-
- endif
-
-! End g-point interval loop
- enddo
-
-! End layer loop
- enddo
-
- end subroutine cldprmc_sw
-
- end module rrtmg_sw_cldprmc
-
-! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
-! author: $Author: trn $
-! revision: $Revision: 1.3 $
-! created: $Date: 2009/04/16 19:54:22 $
-
- module rrtmg_sw_reftra
-
-! --------------------------------------------------------------------------
-! | |
-! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
-! | This software may be used, copied, or redistributed as long as it is |
-! | not sold and this copyright notice is reproduced on each copy made. |
-! | This model is provided as is without any express or implied warranties. |
-! | (http://www.rtweb.aer.com/) |
-! | |
-! --------------------------------------------------------------------------
-
-! ------- Modules -------
-
- use parkind, only : im => kind_im, rb => kind_rb
- use rrsw_tbl, only : tblint, bpade, od_lo, exp_tbl
- use rrsw_vsn, only : hvrrft, hnamrft
-
- implicit none
-
- contains
-
-! --------------------------------------------------------------------
- subroutine reftra_sw(nlayers, lrtchk, pgg, prmuz, ptau, pw, &
- pref, prefd, ptra, ptrad)
-! --------------------------------------------------------------------
-
-! Purpose: computes the reflectivity and transmissivity of a clear or
-! cloudy layer using a choice of various approximations.
-!
-! Interface: *rrtmg_sw_reftra* is called by *rrtmg_sw_spcvrt*
-!
-! Description:
-! explicit arguments :
-! --------------------
-! inputs
-! ------
-! lrtchk = .t. for all layers in clear profile
-! lrtchk = .t. for cloudy layers in cloud profile
-! = .f. for clear layers in cloud profile
-! pgg = assymetry factor
-! prmuz = cosine solar zenith angle
-! ptau = optical thickness
-! pw = single scattering albedo
-!
-! outputs
-! -------
-! pref : collimated beam reflectivity
-! prefd : diffuse beam reflectivity
-! ptra : collimated beam transmissivity
-! ptrad : diffuse beam transmissivity
-!
-!
-! Method:
-! -------
-! standard delta-eddington, p.i.f.m., or d.o.m. layer calculations.
-! kmodts = 1 eddington (joseph et al., 1976)
-! = 2 pifm (zdunkowski et al., 1980)
-! = 3 discrete ordinates (liou, 1973)
-!
-!
-! Modifications:
-! --------------
-! Original: J-JMorcrette, ECMWF, Feb 2003
-! Revised for F90 reformatting: MJIacono, AER, Jul 2006
-! Revised to add exponential lookup table: MJIacono, AER, Aug 2007
-! Reformulated some code to avoid potential fpes: MJIacono, AER, Nov 2008
-!
-! ------------------------------------------------------------------
-
-! ------- Declarations ------
-
-! ------- Input -------
-
- integer(kind=im), intent(in) :: nlayers
-
- logical, intent(in) :: lrtchk(:) ! Logical flag for reflectivity and
- ! and transmissivity calculation;
- ! Dimensions: (nlayers)
-
- real(kind=rb), intent(in) :: pgg(:) ! asymmetry parameter
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: ptau(:) ! optical depth
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: pw(:) ! single scattering albedo
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: prmuz ! cosine of solar zenith angle
-
-! ------- Output -------
-
- real(kind=rb), intent(inout) :: pref(:) ! direct beam reflectivity
- ! Dimensions: (nlayers+1)
- real(kind=rb), intent(inout) :: prefd(:) ! diffuse beam reflectivity
- ! Dimensions: (nlayers+1)
- real(kind=rb), intent(inout) :: ptra(:) ! direct beam transmissivity
- ! Dimensions: (nlayers+1)
- real(kind=rb), intent(inout) :: ptrad(:) ! diffuse beam transmissivity
- ! Dimensions: (nlayers+1)
-
-! ------- Local -------
-
- integer(kind=im) :: jk, jl, kmodts
- integer(kind=im) :: itind
-
- real(kind=rb) :: tblind
- real(kind=rb) :: za, za1, za2
- real(kind=rb) :: zbeta, zdend, zdenr, zdent
- real(kind=rb) :: ze1, ze2, zem1, zem2, zemm, zep1, zep2
- real(kind=rb) :: zg, zg3, zgamma1, zgamma2, zgamma3, zgamma4, zgt
- real(kind=rb) :: zr1, zr2, zr3, zr4, zr5
- real(kind=rb) :: zrk, zrk2, zrkg, zrm1, zrp, zrp1, zrpp
- real(kind=rb) :: zsr3, zt1, zt2, zt3, zt4, zt5, zto1
- real(kind=rb) :: zw, zwcrit, zwo
- real(kind=rb) :: denom
-
- real(kind=rb), parameter :: eps = 1.e-08_rb
-
-! ------------------------------------------------------------------
-
-! Initialize
-
-!jm not thread safe hvrrft = '$Revision: 1.3 $'
-
- zsr3=sqrt(3._rb)
- zwcrit=0.9999995_rb
- kmodts=2
-
- do jk=1, nlayers
- if (.not.lrtchk(jk)) then
- pref(jk) =0._rb
- ptra(jk) =1._rb
- prefd(jk)=0._rb
- ptrad(jk)=1._rb
- else
- zto1=ptau(jk)
- zw =pw(jk)
- zg =pgg(jk)
-
-! General two-stream expressions
-
- zg3= 3._rb * zg
- if (kmodts == 1) then
- zgamma1= (7._rb - zw * (4._rb + zg3)) * 0.25_rb
- zgamma2=-(1._rb - zw * (4._rb - zg3)) * 0.25_rb
- zgamma3= (2._rb - zg3 * prmuz ) * 0.25_rb
- else if (kmodts == 2) then
- zgamma1= (8._rb - zw * (5._rb + zg3)) * 0.25_rb
- zgamma2= 3._rb *(zw * (1._rb - zg )) * 0.25_rb
- zgamma3= (2._rb - zg3 * prmuz ) * 0.25_rb
- else if (kmodts == 3) then
- zgamma1= zsr3 * (2._rb - zw * (1._rb + zg)) * 0.5_rb
- zgamma2= zsr3 * zw * (1._rb - zg ) * 0.5_rb
- zgamma3= (1._rb - zsr3 * zg * prmuz ) * 0.5_rb
- end if
- zgamma4= 1._rb - zgamma3
-
-! Recompute original s.s.a. to test for conservative solution
- zwo = 0._rb
- denom = 1._rb
- if (zg .ne. 1._rb) denom = (1._rb - (1._rb - zw) * (zg / (1._rb - zg))**2)
- if (zw .gt. 0._rb .and. denom .ne. 0._rb) zwo = zw / denom
-
- if (zwo >= zwcrit) then
-! Conservative scattering
-
- za = zgamma1 * prmuz
- za1 = za - zgamma3
- zgt = zgamma1 * zto1
-
-! Homogeneous reflectance and transmittance,
-! collimated beam
-
- ze1 = min ( zto1 / prmuz , 500._rb)
-! ze2 = exp( -ze1 )
-
-! Use exponential lookup table for transmittance, or expansion of
-! exponential for low tau
- if (ze1 .le. od_lo) then
- ze2 = 1._rb - ze1 + 0.5_rb * ze1 * ze1
- else
- tblind = ze1 / (bpade + ze1)
- itind = tblint * tblind + 0.5_rb
- ze2 = exp_tbl(itind)
- endif
-!
-
- pref(jk) = (zgt - za1 * (1._rb - ze2)) / (1._rb + zgt)
- ptra(jk) = 1._rb - pref(jk)
-
-! isotropic incidence
-
- prefd(jk) = zgt / (1._rb + zgt)
- ptrad(jk) = 1._rb - prefd(jk)
-
-! This is applied for consistency between total (delta-scaled) and direct (unscaled)
-! calculations at very low optical depths (tau < 1.e-4) when the exponential lookup
-! table returns a transmittance of 1.0.
- if (ze2 .eq. 1.0_rb) then
- pref(jk) = 0.0_rb
- ptra(jk) = 1.0_rb
- prefd(jk) = 0.0_rb
- ptrad(jk) = 1.0_rb
- endif
-
- else
-! Non-conservative scattering
-
- za1 = zgamma1 * zgamma4 + zgamma2 * zgamma3
- za2 = zgamma1 * zgamma3 + zgamma2 * zgamma4
- zrk = sqrt ( zgamma1**2 - zgamma2**2)
- zrp = zrk * prmuz
- zrp1 = 1._rb + zrp
- zrm1 = 1._rb - zrp
- zrk2 = 2._rb * zrk
- zrpp = 1._rb - zrp*zrp
- zrkg = zrk + zgamma1
- zr1 = zrm1 * (za2 + zrk * zgamma3)
- zr2 = zrp1 * (za2 - zrk * zgamma3)
- zr3 = zrk2 * (zgamma3 - za2 * prmuz )
- zr4 = zrpp * zrkg
- zr5 = zrpp * (zrk - zgamma1)
- zt1 = zrp1 * (za1 + zrk * zgamma4)
- zt2 = zrm1 * (za1 - zrk * zgamma4)
- zt3 = zrk2 * (zgamma4 + za1 * prmuz )
- zt4 = zr4
- zt5 = zr5
-
-! mji - reformulated code to avoid potential floating point exceptions
-! zbeta = - zr5 / zr4
- zbeta = (zgamma1 - zrk) / zrkg
-!!
-
-! Homogeneous reflectance and transmittance
-
- ze1 = min ( zrk * zto1, 500._rb)
- ze2 = min ( zto1 / prmuz , 500._rb)
-!
-! Original
-! zep1 = exp( ze1 )
-! zem1 = exp(-ze1 )
-! zep2 = exp( ze2 )
-! zem2 = exp(-ze2 )
-!
-! Revised original, to reduce exponentials
-! zep1 = exp( ze1 )
-! zem1 = 1._rb / zep1
-! zep2 = exp( ze2 )
-! zem2 = 1._rb / zep2
-!
-! Use exponential lookup table for transmittance, or expansion of
-! exponential for low tau
- if (ze1 .le. od_lo) then
- zem1 = 1._rb - ze1 + 0.5_rb * ze1 * ze1
- zep1 = 1._rb / zem1
- else
- tblind = ze1 / (bpade + ze1)
- itind = tblint * tblind + 0.5_rb
- zem1 = exp_tbl(itind)
- zep1 = 1._rb / zem1
- endif
-
- if (ze2 .le. od_lo) then
- zem2 = 1._rb - ze2 + 0.5_rb * ze2 * ze2
- zep2 = 1._rb / zem2
- else
- tblind = ze2 / (bpade + ze2)
- itind = tblint * tblind + 0.5_rb
- zem2 = exp_tbl(itind)
- zep2 = 1._rb / zem2
- endif
-
-! collimated beam
-
-! mji - reformulated code to avoid potential floating point exceptions
-! zdenr = zr4*zep1 + zr5*zem1
-! pref(jk) = zw * (zr1*zep1 - zr2*zem1 - zr3*zem2) / zdenr
-! zdent = zt4*zep1 + zt5*zem1
-! ptra(jk) = zem2 - zem2 * zw * (zt1*zep1 - zt2*zem1 - zt3*zep2) / zdent
-
- zdenr = zr4*zep1 + zr5*zem1
- zdent = zt4*zep1 + zt5*zem1
- if (zdenr .ge. -eps .and. zdenr .le. eps) then
- pref(jk) = eps
- ptra(jk) = zem2
- else
- pref(jk) = zw * (zr1*zep1 - zr2*zem1 - zr3*zem2) / zdenr
- ptra(jk) = zem2 - zem2 * zw * (zt1*zep1 - zt2*zem1 - zt3*zep2) / zdent
- endif
-!!
-
-! diffuse beam
-
- zemm = zem1*zem1
- zdend = 1._rb / ( (1._rb - zbeta*zemm ) * zrkg)
- prefd(jk) = zgamma2 * (1._rb - zemm) * zdend
- ptrad(jk) = zrk2*zem1*zdend
-
- endif
-
- endif
-
- enddo
-
- end subroutine reftra_sw
-
- end module rrtmg_sw_reftra
-
-! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
-! author: $Author: trn $
-! revision: $Revision: 1.3 $
-! created: $Date: 2009/04/16 19:54:22 $
-
- module rrtmg_sw_setcoef
-
-! --------------------------------------------------------------------------
-! | |
-! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
-! | This software may be used, copied, or redistributed as long as it is |
-! | not sold and this copyright notice is reproduced on each copy made. |
-! | This model is provided as is without any express or implied warranties. |
-! | (http://www.rtweb.aer.com/) |
-! | |
-! --------------------------------------------------------------------------
-
-! ------- Modules -------
-
- use parkind, only : im => kind_im, rb => kind_rb
- use parrrsw, only : mxmol
- use rrsw_ref, only : pref, preflog, tref
- use rrsw_vsn, only : hvrset, hnamset
-
- implicit none
-
- contains
-
-!----------------------------------------------------------------------------
- subroutine setcoef_sw(nlayers, pavel, tavel, pz, tz, tbound, coldry, wkl, &
- laytrop, layswtch, laylow, jp, jt, jt1, &
- co2mult, colch4, colco2, colh2o, colmol, coln2o, &
- colo2, colo3, fac00, fac01, fac10, fac11, &
- selffac, selffrac, indself, forfac, forfrac, indfor)
-!----------------------------------------------------------------------------
-!
-! Purpose: For a given atmosphere, calculate the indices and
-! fractions related to the pressure and temperature interpolations.
-
-! Modifications:
-! Original: J. Delamere, AER, Inc. (version 2.5, 02/04/01)
-! Revised: Rewritten and adapted to ECMWF F90, JJMorcrette 030224
-! Revised: For uniform rrtmg formatting, MJIacono, Jul 2006
-
-! ------ Declarations -------
-
-! ----- Input -----
- integer(kind=im), intent(in) :: nlayers ! total number of layers
-
- real(kind=rb), intent(in) :: pavel(:) ! layer pressures (mb)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: tavel(:) ! layer temperatures (K)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: pz(0:) ! level (interface) pressures (hPa, mb)
- ! Dimensions: (0:nlayers)
- real(kind=rb), intent(in) :: tz(0:) ! level (interface) temperatures (K)
- ! Dimensions: (0:nlayers)
- real(kind=rb), intent(in) :: tbound ! surface temperature (K)
- real(kind=rb), intent(in) :: coldry(:) ! dry air column density (mol/cm2)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: wkl(:,:) ! molecular amounts (mol/cm-2)
- ! Dimensions: (mxmol,nlayers)
-
-! ----- Output -----
- integer(kind=im), intent(out) :: laytrop ! tropopause layer index
- integer(kind=im), intent(out) :: layswtch !
- integer(kind=im), intent(out) :: laylow !
-
- integer(kind=im), intent(out) :: jp(:) !
- ! Dimensions: (nlayers)
- integer(kind=im), intent(out) :: jt(:) !
- ! Dimensions: (nlayers)
- integer(kind=im), intent(out) :: jt1(:) !
- ! Dimensions: (nlayers)
-
- real(kind=rb), intent(out) :: colh2o(:) ! column amount (h2o)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(out) :: colco2(:) ! column amount (co2)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(out) :: colo3(:) ! column amount (o3)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(out) :: coln2o(:) ! column amount (n2o)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(out) :: colch4(:) ! column amount (ch4)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(out) :: colo2(:) ! column amount (o2)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(out) :: colmol(:) !
- ! Dimensions: (nlayers)
- real(kind=rb), intent(out) :: co2mult(:) !
- ! Dimensions: (nlayers)
-
- integer(kind=im), intent(out) :: indself(:)
- ! Dimensions: (nlayers)
- integer(kind=im), intent(out) :: indfor(:)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(out) :: selffac(:)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(out) :: selffrac(:)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(out) :: forfac(:)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(out) :: forfrac(:)
- ! Dimensions: (nlayers)
-
- real(kind=rb), intent(out) :: & !
- fac00(:), fac01(:), & ! Dimensions: (nlayers)
- fac10(:), fac11(:)
-
-! ----- Local -----
-
- integer(kind=im) :: indbound
- integer(kind=im) :: indlev0
- integer(kind=im) :: lay
- integer(kind=im) :: jp1
-
- real(kind=rb) :: stpfac
- real(kind=rb) :: tbndfrac
- real(kind=rb) :: t0frac
- real(kind=rb) :: plog
- real(kind=rb) :: fp
- real(kind=rb) :: ft
- real(kind=rb) :: ft1
- real(kind=rb) :: water
- real(kind=rb) :: scalefac
- real(kind=rb) :: factor
- real(kind=rb) :: co2reg
- real(kind=rb) :: compfp
-
-
-! Initializations
- stpfac = 296._rb/1013._rb
-
- indbound = tbound - 159._rb
- tbndfrac = tbound - int(tbound)
- indlev0 = tz(0) - 159._rb
- t0frac = tz(0) - int(tz(0))
-
- laytrop = 0
- layswtch = 0
- laylow = 0
-
-! Begin layer loop
- do lay = 1, nlayers
-! Find the two reference pressures on either side of the
-! layer pressure. Store them in JP and JP1. Store in FP the
-! fraction of the difference (in ln(pressure)) between these
-! two values that the layer pressure lies.
-
- plog = log(pavel(lay))
- jp(lay) = int(36._rb - 5*(plog+0.04_rb))
- if (jp(lay) .lt. 1) then
- jp(lay) = 1
- elseif (jp(lay) .gt. 58) then
- jp(lay) = 58
- endif
- jp1 = jp(lay) + 1
- fp = 5._rb * (preflog(jp(lay)) - plog)
-
-! Determine, for each reference pressure (JP and JP1), which
-! reference temperature (these are different for each
-! reference pressure) is nearest the layer temperature but does
-! not exceed it. Store these indices in JT and JT1, resp.
-! Store in FT (resp. FT1) the fraction of the way between JT
-! (JT1) and the next highest reference temperature that the
-! layer temperature falls.
-
- jt(lay) = int(3._rb + (tavel(lay)-tref(jp(lay)))/15._rb)
- if (jt(lay) .lt. 1) then
- jt(lay) = 1
- elseif (jt(lay) .gt. 4) then
- jt(lay) = 4
- endif
- ft = ((tavel(lay)-tref(jp(lay)))/15._rb) - float(jt(lay)-3)
- jt1(lay) = int(3._rb + (tavel(lay)-tref(jp1))/15._rb)
- if (jt1(lay) .lt. 1) then
- jt1(lay) = 1
- elseif (jt1(lay) .gt. 4) then
- jt1(lay) = 4
- endif
- ft1 = ((tavel(lay)-tref(jp1))/15._rb) - float(jt1(lay)-3)
-
- water = wkl(1,lay)/coldry(lay)
- scalefac = pavel(lay) * stpfac / tavel(lay)
-
-! If the pressure is less than ~100mb, perform a different
-! set of species interpolations.
-
- if (plog .le. 4.56_rb) go to 5300
- laytrop = laytrop + 1
- if (plog .ge. 6.62_rb) laylow = laylow + 1
-
-! Set up factors needed to separately include the water vapor
-! foreign-continuum in the calculation of absorption coefficient.
-
- forfac(lay) = scalefac / (1.+water)
- factor = (332.0_rb-tavel(lay))/36.0_rb
- indfor(lay) = min(2, max(1, int(factor)))
- forfrac(lay) = factor - float(indfor(lay))
-
-! Set up factors needed to separately include the water vapor
-! self-continuum in the calculation of absorption coefficient.
-
- selffac(lay) = water * forfac(lay)
- factor = (tavel(lay)-188.0_rb)/7.2_rb
- indself(lay) = min(9, max(1, int(factor)-7))
- selffrac(lay) = factor - float(indself(lay) + 7)
-
-! Calculate needed column amounts.
-
- colh2o(lay) = 1.e-20_rb * wkl(1,lay)
- colco2(lay) = 1.e-20_rb * wkl(2,lay)
- colo3(lay) = 1.e-20_rb * wkl(3,lay)
-! colo3(lay) = 0._rb
-! colo3(lay) = colo3(lay)/1.16_rb
- coln2o(lay) = 1.e-20_rb * wkl(4,lay)
- colch4(lay) = 1.e-20_rb * wkl(6,lay)
- colo2(lay) = 1.e-20_rb * wkl(7,lay)
- colmol(lay) = 1.e-20_rb * coldry(lay) + colh2o(lay)
-! colco2(lay) = 0._rb
-! colo3(lay) = 0._rb
-! coln2o(lay) = 0._rb
-! colch4(lay) = 0._rb
-! colo2(lay) = 0._rb
-! colmol(lay) = 0._rb
- if (colco2(lay) .eq. 0._rb) colco2(lay) = 1.e-32_rb * coldry(lay)
- if (coln2o(lay) .eq. 0._rb) coln2o(lay) = 1.e-32_rb * coldry(lay)
- if (colch4(lay) .eq. 0._rb) colch4(lay) = 1.e-32_rb * coldry(lay)
- if (colo2(lay) .eq. 0._rb) colo2(lay) = 1.e-32_rb * coldry(lay)
-! Using E = 1334.2 cm-1.
- co2reg = 3.55e-24_rb * coldry(lay)
- co2mult(lay)= (colco2(lay) - co2reg) * &
- 272.63_rb*exp(-1919.4_rb/tavel(lay))/(8.7604e-4_rb*tavel(lay))
- goto 5400
-
-! Above laytrop.
- 5300 continue
-
-! Set up factors needed to separately include the water vapor
-! foreign-continuum in the calculation of absorption coefficient.
-
- forfac(lay) = scalefac / (1.+water)
- factor = (tavel(lay)-188.0_rb)/36.0_rb
- indfor(lay) = 3
- forfrac(lay) = factor - 1.0_rb
-
-! Calculate needed column amounts.
-
- colh2o(lay) = 1.e-20_rb * wkl(1,lay)
- colco2(lay) = 1.e-20_rb * wkl(2,lay)
- colo3(lay) = 1.e-20_rb * wkl(3,lay)
- coln2o(lay) = 1.e-20_rb * wkl(4,lay)
- colch4(lay) = 1.e-20_rb * wkl(6,lay)
- colo2(lay) = 1.e-20_rb * wkl(7,lay)
- colmol(lay) = 1.e-20_rb * coldry(lay) + colh2o(lay)
- if (colco2(lay) .eq. 0._rb) colco2(lay) = 1.e-32_rb * coldry(lay)
- if (coln2o(lay) .eq. 0._rb) coln2o(lay) = 1.e-32_rb * coldry(lay)
- if (colch4(lay) .eq. 0._rb) colch4(lay) = 1.e-32_rb * coldry(lay)
- if (colo2(lay) .eq. 0._rb) colo2(lay) = 1.e-32_rb * coldry(lay)
- co2reg = 3.55e-24_rb * coldry(lay)
- co2mult(lay)= (colco2(lay) - co2reg) * &
- 272.63_rb*exp(-1919.4_rb/tavel(lay))/(8.7604e-4_rb*tavel(lay))
-
- selffac(lay) = 0._rb
- selffrac(lay)= 0._rb
- indself(lay) = 0
-
- 5400 continue
-
-! We have now isolated the layer ln pressure and temperature,
-! between two reference pressures and two reference temperatures
-! (for each reference pressure). We multiply the pressure
-! fraction FP with the appropriate temperature fractions to get
-! the factors that will be needed for the interpolation that yields
-! the optical depths (performed in routines TAUGBn for band n).
-
- compfp = 1._rb - fp
- fac10(lay) = compfp * ft
- fac00(lay) = compfp * (1._rb - ft)
- fac11(lay) = fp * ft1
- fac01(lay) = fp * (1._rb - ft1)
-
-! End layer loop
- enddo
-
- end subroutine setcoef_sw
-
-!***************************************************************************
- subroutine swatmref
-!***************************************************************************
-
- save
-
-! These pressures are chosen such that the ln of the first pressure
-! has only a few non-zero digits (i.e. ln(PREF(1)) = 6.96000) and
-! each subsequent ln(pressure) differs from the previous one by 0.2.
-
- pref(:) = (/ &
- 1.05363e+03_rb,8.62642e+02_rb,7.06272e+02_rb,5.78246e+02_rb,4.73428e+02_rb, &
- 3.87610e+02_rb,3.17348e+02_rb,2.59823e+02_rb,2.12725e+02_rb,1.74164e+02_rb, &
- 1.42594e+02_rb,1.16746e+02_rb,9.55835e+01_rb,7.82571e+01_rb,6.40715e+01_rb, &
- 5.24573e+01_rb,4.29484e+01_rb,3.51632e+01_rb,2.87892e+01_rb,2.35706e+01_rb, &
- 1.92980e+01_rb,1.57998e+01_rb,1.29358e+01_rb,1.05910e+01_rb,8.67114e+00_rb, &
- 7.09933e+00_rb,5.81244e+00_rb,4.75882e+00_rb,3.89619e+00_rb,3.18993e+00_rb, &
- 2.61170e+00_rb,2.13828e+00_rb,1.75067e+00_rb,1.43333e+00_rb,1.17351e+00_rb, &
- 9.60789e-01_rb,7.86628e-01_rb,6.44036e-01_rb,5.27292e-01_rb,4.31710e-01_rb, &
- 3.53455e-01_rb,2.89384e-01_rb,2.36928e-01_rb,1.93980e-01_rb,1.58817e-01_rb, &
- 1.30029e-01_rb,1.06458e-01_rb,8.71608e-02_rb,7.13612e-02_rb,5.84256e-02_rb, &
- 4.78349e-02_rb,3.91639e-02_rb,3.20647e-02_rb,2.62523e-02_rb,2.14936e-02_rb, &
- 1.75975e-02_rb,1.44076e-02_rb,1.17959e-02_rb,9.65769e-03_rb /)
-
- preflog(:) = (/ &
- 6.9600e+00_rb, 6.7600e+00_rb, 6.5600e+00_rb, 6.3600e+00_rb, 6.1600e+00_rb, &
- 5.9600e+00_rb, 5.7600e+00_rb, 5.5600e+00_rb, 5.3600e+00_rb, 5.1600e+00_rb, &
- 4.9600e+00_rb, 4.7600e+00_rb, 4.5600e+00_rb, 4.3600e+00_rb, 4.1600e+00_rb, &
- 3.9600e+00_rb, 3.7600e+00_rb, 3.5600e+00_rb, 3.3600e+00_rb, 3.1600e+00_rb, &
- 2.9600e+00_rb, 2.7600e+00_rb, 2.5600e+00_rb, 2.3600e+00_rb, 2.1600e+00_rb, &
- 1.9600e+00_rb, 1.7600e+00_rb, 1.5600e+00_rb, 1.3600e+00_rb, 1.1600e+00_rb, &
- 9.6000e-01_rb, 7.6000e-01_rb, 5.6000e-01_rb, 3.6000e-01_rb, 1.6000e-01_rb, &
- -4.0000e-02_rb,-2.4000e-01_rb,-4.4000e-01_rb,-6.4000e-01_rb,-8.4000e-01_rb, &
- -1.0400e+00_rb,-1.2400e+00_rb,-1.4400e+00_rb,-1.6400e+00_rb,-1.8400e+00_rb, &
- -2.0400e+00_rb,-2.2400e+00_rb,-2.4400e+00_rb,-2.6400e+00_rb,-2.8400e+00_rb, &
- -3.0400e+00_rb,-3.2400e+00_rb,-3.4400e+00_rb,-3.6400e+00_rb,-3.8400e+00_rb, &
- -4.0400e+00_rb,-4.2400e+00_rb,-4.4400e+00_rb,-4.6400e+00_rb /)
-
-! These are the temperatures associated with the respective
-! pressures for the MLS standard atmosphere.
-
- tref(:) = (/ &
- 2.9420e+02_rb, 2.8799e+02_rb, 2.7894e+02_rb, 2.6925e+02_rb, 2.5983e+02_rb, &
- 2.5017e+02_rb, 2.4077e+02_rb, 2.3179e+02_rb, 2.2306e+02_rb, 2.1578e+02_rb, &
- 2.1570e+02_rb, 2.1570e+02_rb, 2.1570e+02_rb, 2.1706e+02_rb, 2.1858e+02_rb, &
- 2.2018e+02_rb, 2.2174e+02_rb, 2.2328e+02_rb, 2.2479e+02_rb, 2.2655e+02_rb, &
- 2.2834e+02_rb, 2.3113e+02_rb, 2.3401e+02_rb, 2.3703e+02_rb, 2.4022e+02_rb, &
- 2.4371e+02_rb, 2.4726e+02_rb, 2.5085e+02_rb, 2.5457e+02_rb, 2.5832e+02_rb, &
- 2.6216e+02_rb, 2.6606e+02_rb, 2.6999e+02_rb, 2.7340e+02_rb, 2.7536e+02_rb, &
- 2.7568e+02_rb, 2.7372e+02_rb, 2.7163e+02_rb, 2.6955e+02_rb, 2.6593e+02_rb, &
- 2.6211e+02_rb, 2.5828e+02_rb, 2.5360e+02_rb, 2.4854e+02_rb, 2.4348e+02_rb, &
- 2.3809e+02_rb, 2.3206e+02_rb, 2.2603e+02_rb, 2.2000e+02_rb, 2.1435e+02_rb, &
- 2.0887e+02_rb, 2.0340e+02_rb, 1.9792e+02_rb, 1.9290e+02_rb, 1.8809e+02_rb, &
- 1.8329e+02_rb, 1.7849e+02_rb, 1.7394e+02_rb, 1.7212e+02_rb /)
-
- end subroutine swatmref
-
- end module rrtmg_sw_setcoef
-
-! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
-! author: $Author: trn $
-! revision: $Revision: 1.3 $
-! created: $Date: 2009/04/16 19:54:22 $
-
- module rrtmg_sw_taumol
-
-! --------------------------------------------------------------------------
-! | |
-! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
-! | This software may be used, copied, or redistributed as long as it is |
-! | not sold and this copyright notice is reproduced on each copy made. |
-! | This model is provided as is without any express or implied warranties. |
-! | (http://www.rtweb.aer.com/) |
-! | |
-! --------------------------------------------------------------------------
-
-! ------- Modules -------
-
- use parkind, only : im => kind_im, rb => kind_rb
-! use parrrsw, only : mg, jpband, nbndsw, ngptsw
- use rrsw_con, only: oneminus
- use rrsw_wvn, only: nspa, nspb
- use rrsw_vsn, only: hvrtau, hnamtau
-
- implicit none
-
- contains
-
-!----------------------------------------------------------------------------
- subroutine taumol_sw(nlayers, &
- colh2o, colco2, colch4, colo2, colo3, colmol, &
- laytrop, jp, jt, jt1, &
- fac00, fac01, fac10, fac11, &
- selffac, selffrac, indself, forfac, forfrac, indfor, &
- sfluxzen, taug, taur)
-!----------------------------------------------------------------------------
-
-! ******************************************************************************
-! * *
-! * Optical depths developed for the *
-! * *
-! * RAPID RADIATIVE TRANSFER MODEL (RRTM) *
-! * *
-! * *
-! * ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC. *
-! * 131 HARTWELL AVENUE *
-! * LEXINGTON, MA 02421 *
-! * *
-! * *
-! * ELI J. MLAWER *
-! * JENNIFER DELAMERE *
-! * STEVEN J. TAUBMAN *
-! * SHEPARD A. CLOUGH *
-! * *
-! * *
-! * *
-! * *
-! * email: mlawer@aer.com *
-! * email: jdelamer@aer.com *
-! * *
-! * The authors wish to acknowledge the contributions of the *
-! * following people: Patrick D. Brown, Michael J. Iacono, *
-! * Ronald E. Farren, Luke Chen, Robert Bergstrom. *
-! * *
-! ******************************************************************************
-! * TAUMOL *
-! * *
-! * This file contains the subroutines TAUGBn (where n goes from *
-! * 1 to 28). TAUGBn calculates the optical depths and Planck fractions *
-! * per g-value and layer for band n. *
-! * *
-! * Output: optical depths (unitless) *
-! * fractions needed to compute Planck functions at every layer *
-! * and g-value *
-! * *
-! * COMMON /TAUGCOM/ TAUG(MXLAY,MG) *
-! * COMMON /PLANKG/ FRACS(MXLAY,MG) *
-! * *
-! * Input *
-! * *
-! * PARAMETER (MG=16, MXLAY=203, NBANDS=14) *
-! * *
-! * COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS) *
-! * COMMON /PRECISE/ ONEMINUS *
-! * COMMON /PROFILE/ NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY), *
-! * & PZ(0:MXLAY),TZ(0:MXLAY),TBOUND *
-! * COMMON /PROFDATA/ LAYTROP,LAYSWTCH,LAYLOW, *
-! * & COLH2O(MXLAY),COLCO2(MXLAY), *
-! * & COLO3(MXLAY),COLN2O(MXLAY),COLCH4(MXLAY), *
-! * & COLO2(MXLAY),CO2MULT(MXLAY) *
-! * COMMON /INTFAC/ FAC00(MXLAY),FAC01(MXLAY), *
-! * & FAC10(MXLAY),FAC11(MXLAY) *
-! * COMMON /INTIND/ JP(MXLAY),JT(MXLAY),JT1(MXLAY) *
-! * COMMON /SELF/ SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY) *
-! * *
-! * Description: *
-! * NG(IBAND) - number of g-values in band IBAND *
-! * NSPA(IBAND) - for the lower atmosphere, the number of reference *
-! * atmospheres that are stored for band IBAND per *
-! * pressure level and temperature. Each of these *
-! * atmospheres has different relative amounts of the *
-! * key species for the band (i.e. different binary *
-! * species parameters). *
-! * NSPB(IBAND) - same for upper atmosphere *
-! * ONEMINUS - since problems are caused in some cases by interpolation *
-! * parameters equal to or greater than 1, for these cases *
-! * these parameters are set to this value, slightly < 1. *
-! * PAVEL - layer pressures (mb) *
-! * TAVEL - layer temperatures (degrees K) *
-! * PZ - level pressures (mb) *
-! * TZ - level temperatures (degrees K) *
-! * LAYTROP - layer at which switch is made from one combination of *
-! * key species to another *
-! * COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water *
-! * vapor,carbon dioxide, ozone, nitrous ozide, methane, *
-! * respectively (molecules/cm**2) *
-! * CO2MULT - for bands in which carbon dioxide is implemented as a *
-! * trace species, this is the factor used to multiply the *
-! * band's average CO2 absorption coefficient to get the added *
-! * contribution to the optical depth relative to 355 ppm. *
-! * FACij(LAY) - for layer LAY, these are factors that are needed to *
-! * compute the interpolation factors that multiply the *
-! * appropriate reference k-values. A value of 0 (1) for *
-! * i,j indicates that the corresponding factor multiplies *
-! * reference k-value for the lower (higher) of the two *
-! * appropriate temperatures, and altitudes, respectively. *
-! * JP - the index of the lower (in altitude) of the two appropriate *
-! * reference pressure levels needed for interpolation *
-! * JT, JT1 - the indices of the lower of the two appropriate reference *
-! * temperatures needed for interpolation (for pressure *
-! * levels JP and JP+1, respectively) *
-! * SELFFAC - scale factor needed to water vapor self-continuum, equals *
-! * (water vapor density)/(atmospheric density at 296K and *
-! * 1013 mb) *
-! * SELFFRAC - factor needed for temperature interpolation of reference *
-! * water vapor self-continuum data *
-! * INDSELF - index of the lower of the two appropriate reference *
-! * temperatures needed for the self-continuum interpolation *
-! * *
-! * Data input *
-! * COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG) *
-! * (note: n is the band number) *
-! * *
-! * Description: *
-! * KA - k-values for low reference atmospheres (no water vapor *
-! * self-continuum) (units: cm**2/molecule) *
-! * KB - k-values for high reference atmospheres (all sources) *
-! * (units: cm**2/molecule) *
-! * SELFREF - k-values for water vapor self-continuum for reference *
-! * atmospheres (used below LAYTROP) *
-! * (units: cm**2/molecule) *
-! * *
-! * DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG) *
-! * EQUIVALENCE (KA,ABSA),(KB,ABSB) *
-! * *
-! *****************************************************************************
-!
-! Modifications
-!
-! Revised: Adapted to F90 coding, J.-J.Morcrette, ECMWF, Feb 2003
-! Revised: Modified for g-point reduction, MJIacono, AER, Dec 2003
-! Revised: Reformatted for consistency with rrtmg_lw, MJIacono, AER, Jul 2006
-!
-! ------- Declarations -------
-
-! ----- Input -----
- integer(kind=im), intent(in) :: nlayers ! total number of layers
-
- integer(kind=im), intent(in) :: laytrop ! tropopause layer index
- integer(kind=im), intent(in) :: jp(:) !
- ! Dimensions: (nlayers)
- integer(kind=im), intent(in) :: jt(:) !
- ! Dimensions: (nlayers)
- integer(kind=im), intent(in) :: jt1(:) !
- ! Dimensions: (nlayers)
-
- real(kind=rb), intent(in) :: colh2o(:) ! column amount (h2o)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: colco2(:) ! column amount (co2)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: colo3(:) ! column amount (o3)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: colch4(:) ! column amount (ch4)
- ! Dimensions: (nlayers)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: colo2(:) ! column amount (o2)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: colmol(:) !
- ! Dimensions: (nlayers)
-
- integer(kind=im), intent(in) :: indself(:)
- ! Dimensions: (nlayers)
- integer(kind=im), intent(in) :: indfor(:)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: selffac(:)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: selffrac(:)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: forfac(:)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: forfrac(:)
- ! Dimensions: (nlayers)
-
- real(kind=rb), intent(in) :: & !
- fac00(:), fac01(:), & ! Dimensions: (nlayers)
- fac10(:), fac11(:)
-
-! ----- Output -----
- real(kind=rb), intent(out) :: sfluxzen(:) ! solar source function
- ! Dimensions: (ngptsw)
- real(kind=rb), intent(out) :: taug(:,:) ! gaseous optical depth
- ! Dimensions: (nlayers,ngptsw)
- real(kind=rb), intent(out) :: taur(:,:) ! Rayleigh
- ! Dimensions: (nlayers,ngptsw)
-! real(kind=rb), intent(out) :: ssa(:,:) ! single scattering albedo (inactive)
- ! Dimensions: (nlayers,ngptsw)
-
-!jm not thread safe hvrtau = '$Revision: 1.3 $'
-
-! Initialize sfluxzen to 0.0 to prevent junk values when nlayers = laytrop
-
- sfluxzen(:) = 0.0
-
-! Calculate gaseous optical depth and planck fractions for each spectral band.
-
- call taumol16
- call taumol17
- call taumol18
- call taumol19
- call taumol20
- call taumol21
- call taumol22
- call taumol23
- call taumol24
- call taumol25
- call taumol26
- call taumol27
- call taumol28
- call taumol29
-
-!-------------
- contains
-!-------------
-
-!----------------------------------------------------------------------------
- subroutine taumol16
-!----------------------------------------------------------------------------
-!
-! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4)
-!
-!----------------------------------------------------------------------------
-
-! ------- Modules -------
-
- use parrrsw, only : ng16
- use rrsw_kg16, only : absa, ka, absb, kb, forref, selfref, &
- sfluxref, rayl, layreffr, strrat1
-
-! ------- Declarations -------
-
-! Local
-
- integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
- real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
- fac110, fac111, fs, speccomb, specmult, specparm, &
- tauray
-
-! Compute the optical depth by interpolating in ln(pressure),
-! temperature, and appropriate species. Below LAYTROP, the water
-! vapor self-continuum is interpolated (in temperature) separately.
-
-! Lower atmosphere loop
- do lay = 1, laytrop
- speccomb = colh2o(lay) + strrat1*colch4(lay)
- specparm = colh2o(lay)/speccomb
- if (specparm .ge. oneminus) specparm = oneminus
- specmult = 8._rb*(specparm)
- js = 1 + int(specmult)
- fs = mod(specmult, 1._rb )
- fac000 = (1._rb - fs) * fac00(lay)
- fac010 = (1._rb - fs) * fac10(lay)
- fac100 = fs * fac00(lay)
- fac110 = fs * fac10(lay)
- fac001 = (1._rb - fs) * fac01(lay)
- fac011 = (1._rb - fs) * fac11(lay)
- fac101 = fs * fac01(lay)
- fac111 = fs * fac11(lay)
- ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(16) + js
- ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(16) + js
- inds = indself(lay)
- indf = indfor(lay)
- tauray = colmol(lay) * rayl
-
- do ig = 1, ng16
- taug(lay,ig) = speccomb * &
- (fac000 * absa(ind0 ,ig) + &
- fac100 * absa(ind0 +1,ig) + &
- fac010 * absa(ind0 +9,ig) + &
- fac110 * absa(ind0+10,ig) + &
- fac001 * absa(ind1 ,ig) + &
- fac101 * absa(ind1 +1,ig) + &
- fac011 * absa(ind1 +9,ig) + &
- fac111 * absa(ind1+10,ig)) + &
- colh2o(lay) * &
- (selffac(lay) * (selfref(inds,ig) + &
- selffrac(lay) * &
- (selfref(inds+1,ig) - selfref(inds,ig))) + &
- forfac(lay) * (forref(indf,ig) + &
- forfrac(lay) * &
- (forref(indf+1,ig) - forref(indf,ig))))
-! ssa(lay,ig) = tauray/taug(lay,ig)
- taur(lay,ig) = tauray
- enddo
- enddo
-
- laysolfr = nlayers
-
-! Upper atmosphere loop
- do lay = laytrop+1, nlayers
- if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) &
- laysolfr = lay
- ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(16) + 1
- ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(16) + 1
- tauray = colmol(lay) * rayl
-
- do ig = 1, ng16
- taug(lay,ig) = colch4(lay) * &
- (fac00(lay) * absb(ind0 ,ig) + &
- fac10(lay) * absb(ind0+1,ig) + &
- fac01(lay) * absb(ind1 ,ig) + &
- fac11(lay) * absb(ind1+1,ig))
-! ssa(lay,ig) = tauray/taug(lay,ig)
- if (lay .eq. laysolfr) sfluxzen(ig) = sfluxref(ig)
- taur(lay,ig) = tauray
- enddo
- enddo
-
- end subroutine taumol16
-
-!----------------------------------------------------------------------------
- subroutine taumol17
-!----------------------------------------------------------------------------
-!
-! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
-!
-!----------------------------------------------------------------------------
-
-! ------- Modules -------
-
- use parrrsw, only : ng17, ngs16
- use rrsw_kg17, only : absa, ka, absb, kb, forref, selfref, &
- sfluxref, rayl, layreffr, strrat
-
-! ------- Declarations -------
-
-! Local
-
- integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
- real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
- fac110, fac111, fs, speccomb, specmult, specparm, &
- tauray
-
-! Compute the optical depth by interpolating in ln(pressure),
-! temperature, and appropriate species. Below LAYTROP, the water
-! vapor self-continuum is interpolated (in temperature) separately.
-
-! Lower atmosphere loop
- do lay = 1, laytrop
- speccomb = colh2o(lay) + strrat*colco2(lay)
- specparm = colh2o(lay)/speccomb
- if (specparm .ge. oneminus) specparm = oneminus
- specmult = 8._rb*(specparm)
- js = 1 + int(specmult)
- fs = mod(specmult, 1._rb )
- fac000 = (1._rb - fs) * fac00(lay)
- fac010 = (1._rb - fs) * fac10(lay)
- fac100 = fs * fac00(lay)
- fac110 = fs * fac10(lay)
- fac001 = (1._rb - fs) * fac01(lay)
- fac011 = (1._rb - fs) * fac11(lay)
- fac101 = fs * fac01(lay)
- fac111 = fs * fac11(lay)
- ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(17) + js
- ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(17) + js
- inds = indself(lay)
- indf = indfor(lay)
- tauray = colmol(lay) * rayl
-
- do ig = 1, ng17
- taug(lay,ngs16+ig) = speccomb * &
- (fac000 * absa(ind0,ig) + &
- fac100 * absa(ind0+1,ig) + &
- fac010 * absa(ind0+9,ig) + &
- fac110 * absa(ind0+10,ig) + &
- fac001 * absa(ind1,ig) + &
- fac101 * absa(ind1+1,ig) + &
- fac011 * absa(ind1+9,ig) + &
- fac111 * absa(ind1+10,ig)) + &
- colh2o(lay) * &
- (selffac(lay) * (selfref(inds,ig) + &
- selffrac(lay) * &
- (selfref(inds+1,ig) - selfref(inds,ig))) + &
- forfac(lay) * (forref(indf,ig) + &
- forfrac(lay) * &
- (forref(indf+1,ig) - forref(indf,ig))))
-! ssa(lay,ngs16+ig) = tauray/taug(lay,ngs16+ig)
- taur(lay,ngs16+ig) = tauray
- enddo
- enddo
-
- laysolfr = nlayers
-
-! Upper atmosphere loop
- do lay = laytrop+1, nlayers
- if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) &
- laysolfr = lay
- speccomb = colh2o(lay) + strrat*colco2(lay)
- specparm = colh2o(lay)/speccomb
- if (specparm .ge. oneminus) specparm = oneminus
- specmult = 4._rb*(specparm)
- js = 1 + int(specmult)
- fs = mod(specmult, 1._rb )
- fac000 = (1._rb - fs) * fac00(lay)
- fac010 = (1._rb - fs) * fac10(lay)
- fac100 = fs * fac00(lay)
- fac110 = fs * fac10(lay)
- fac001 = (1._rb - fs) * fac01(lay)
- fac011 = (1._rb - fs) * fac11(lay)
- fac101 = fs * fac01(lay)
- fac111 = fs * fac11(lay)
- ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(17) + js
- ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(17) + js
- indf = indfor(lay)
- tauray = colmol(lay) * rayl
-
- do ig = 1, ng17
- taug(lay,ngs16+ig) = speccomb * &
- (fac000 * absb(ind0,ig) + &
- fac100 * absb(ind0+1,ig) + &
- fac010 * absb(ind0+5,ig) + &
- fac110 * absb(ind0+6,ig) + &
- fac001 * absb(ind1,ig) + &
- fac101 * absb(ind1+1,ig) + &
- fac011 * absb(ind1+5,ig) + &
- fac111 * absb(ind1+6,ig)) + &
- colh2o(lay) * &
- forfac(lay) * (forref(indf,ig) + &
- forfrac(lay) * &
- (forref(indf+1,ig) - forref(indf,ig)))
-! ssa(lay,ngs16+ig) = tauray/taug(lay,ngs16+ig)
- if (lay .eq. laysolfr) sfluxzen(ngs16+ig) = sfluxref(ig,js) &
- + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
- taur(lay,ngs16+ig) = tauray
- enddo
- enddo
-
- end subroutine taumol17
-
-!----------------------------------------------------------------------------
- subroutine taumol18
-!----------------------------------------------------------------------------
-!
-! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4)
-!
-!----------------------------------------------------------------------------
-
-! ------- Modules -------
-
- use parrrsw, only : ng18, ngs17
- use rrsw_kg18, only : absa, ka, absb, kb, forref, selfref, &
- sfluxref, rayl, layreffr, strrat
-
-! ------- Declarations -------
-
-! Local
-
- integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
- real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
- fac110, fac111, fs, speccomb, specmult, specparm, &
- tauray
-
-! Compute the optical depth by interpolating in ln(pressure),
-! temperature, and appropriate species. Below LAYTROP, the water
-! vapor self-continuum is interpolated (in temperature) separately.
-
- laysolfr = laytrop
-
-! Lower atmosphere loop
- do lay = 1, laytrop
- if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
- laysolfr = min(lay+1,laytrop)
- speccomb = colh2o(lay) + strrat*colch4(lay)
- specparm = colh2o(lay)/speccomb
- if (specparm .ge. oneminus) specparm = oneminus
- specmult = 8._rb*(specparm)
- js = 1 + int(specmult)
- fs = mod(specmult, 1._rb )
- fac000 = (1._rb - fs) * fac00(lay)
- fac010 = (1._rb - fs) * fac10(lay)
- fac100 = fs * fac00(lay)
- fac110 = fs * fac10(lay)
- fac001 = (1._rb - fs) * fac01(lay)
- fac011 = (1._rb - fs) * fac11(lay)
- fac101 = fs * fac01(lay)
- fac111 = fs * fac11(lay)
- ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(18) + js
- ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(18) + js
- inds = indself(lay)
- indf = indfor(lay)
- tauray = colmol(lay) * rayl
-
- do ig = 1, ng18
- taug(lay,ngs17+ig) = speccomb * &
- (fac000 * absa(ind0,ig) + &
- fac100 * absa(ind0+1,ig) + &
- fac010 * absa(ind0+9,ig) + &
- fac110 * absa(ind0+10,ig) + &
- fac001 * absa(ind1,ig) + &
- fac101 * absa(ind1+1,ig) + &
- fac011 * absa(ind1+9,ig) + &
- fac111 * absa(ind1+10,ig)) + &
- colh2o(lay) * &
- (selffac(lay) * (selfref(inds,ig) + &
- selffrac(lay) * &
- (selfref(inds+1,ig) - selfref(inds,ig))) + &
- forfac(lay) * (forref(indf,ig) + &
- forfrac(lay) * &
- (forref(indf+1,ig) - forref(indf,ig))))
-! ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig)
- if (lay .eq. laysolfr) sfluxzen(ngs17+ig) = sfluxref(ig,js) &
- + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
- taur(lay,ngs17+ig) = tauray
- enddo
- enddo
-
-! Upper atmosphere loop
- do lay = laytrop+1, nlayers
- ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(18) + 1
- ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(18) + 1
- tauray = colmol(lay) * rayl
-
- do ig = 1, ng18
- taug(lay,ngs17+ig) = colch4(lay) * &
- (fac00(lay) * absb(ind0,ig) + &
- fac10(lay) * absb(ind0+1,ig) + &
- fac01(lay) * absb(ind1,ig) + &
- fac11(lay) * absb(ind1+1,ig))
-! ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig)
- taur(lay,ngs17+ig) = tauray
- enddo
- enddo
-
- end subroutine taumol18
-
-!----------------------------------------------------------------------------
- subroutine taumol19
-!----------------------------------------------------------------------------
-!
-! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2)
-!
-!----------------------------------------------------------------------------
-
-! ------- Modules -------
-
- use parrrsw, only : ng19, ngs18
- use rrsw_kg19, only : absa, ka, absb, kb, forref, selfref, &
- sfluxref, rayl, layreffr, strrat
-
-! ------- Declarations -------
-
-! Local
-
- integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
- real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
- fac110, fac111, fs, speccomb, specmult, specparm, &
- tauray
-
-! Compute the optical depth by interpolating in ln(pressure),
-! temperature, and appropriate species. Below LAYTROP, the water
-! vapor self-continuum is interpolated (in temperature) separately.
-
- laysolfr = laytrop
-
-! Lower atmosphere loop
- do lay = 1, laytrop
- if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
- laysolfr = min(lay+1,laytrop)
- speccomb = colh2o(lay) + strrat*colco2(lay)
- specparm = colh2o(lay)/speccomb
- if (specparm .ge. oneminus) specparm = oneminus
- specmult = 8._rb*(specparm)
- js = 1 + int(specmult)
- fs = mod(specmult, 1._rb )
- fac000 = (1._rb - fs) * fac00(lay)
- fac010 = (1._rb - fs) * fac10(lay)
- fac100 = fs * fac00(lay)
- fac110 = fs * fac10(lay)
- fac001 = (1._rb - fs) * fac01(lay)
- fac011 = (1._rb - fs) * fac11(lay)
- fac101 = fs * fac01(lay)
- fac111 = fs * fac11(lay)
- ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(19) + js
- ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(19) + js
- inds = indself(lay)
- indf = indfor(lay)
- tauray = colmol(lay) * rayl
-
- do ig = 1 , ng19
- taug(lay,ngs18+ig) = speccomb * &
- (fac000 * absa(ind0,ig) + &
- fac100 * absa(ind0+1,ig) + &
- fac010 * absa(ind0+9,ig) + &
- fac110 * absa(ind0+10,ig) + &
- fac001 * absa(ind1,ig) + &
- fac101 * absa(ind1+1,ig) + &
- fac011 * absa(ind1+9,ig) + &
- fac111 * absa(ind1+10,ig)) + &
- colh2o(lay) * &
- (selffac(lay) * (selfref(inds,ig) + &
- selffrac(lay) * &
- (selfref(inds+1,ig) - selfref(inds,ig))) + &
- forfac(lay) * (forref(indf,ig) + &
- forfrac(lay) * &
- (forref(indf+1,ig) - forref(indf,ig))))
-! ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig)
- if (lay .eq. laysolfr) sfluxzen(ngs18+ig) = sfluxref(ig,js) &
- + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
- taur(lay,ngs18+ig) = tauray
- enddo
- enddo
-
-! Upper atmosphere loop
- do lay = laytrop+1, nlayers
- ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(19) + 1
- ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(19) + 1
- tauray = colmol(lay) * rayl
-
- do ig = 1 , ng19
- taug(lay,ngs18+ig) = colco2(lay) * &
- (fac00(lay) * absb(ind0,ig) + &
- fac10(lay) * absb(ind0+1,ig) + &
- fac01(lay) * absb(ind1,ig) + &
- fac11(lay) * absb(ind1+1,ig))
-! ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig)
- taur(lay,ngs18+ig) = tauray
- enddo
- enddo
-
- end subroutine taumol19
-
-!----------------------------------------------------------------------------
- subroutine taumol20
-!----------------------------------------------------------------------------
-!
-! band 20: 5150-6150 cm-1 (low - h2o; high - h2o)
-!
-!----------------------------------------------------------------------------
-
-! ------- Modules -------
-
- use parrrsw, only : ng20, ngs19
- use rrsw_kg20, only : absa, ka, absb, kb, forref, selfref, &
- sfluxref, absch4, rayl, layreffr
-
- implicit none
-
-! ------- Declarations -------
-
-! Local
-
- integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
- real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
- fac110, fac111, fs, speccomb, specmult, specparm, &
- tauray
-
-! Compute the optical depth by interpolating in ln(pressure),
-! temperature, and appropriate species. Below LAYTROP, the water
-! vapor self-continuum is interpolated (in temperature) separately.
-
- laysolfr = laytrop
-
-! Lower atmosphere loop
- do lay = 1, laytrop
- if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
- laysolfr = min(lay+1,laytrop)
- ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(20) + 1
- ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(20) + 1
- inds = indself(lay)
- indf = indfor(lay)
- tauray = colmol(lay) * rayl
-
- do ig = 1, ng20
- taug(lay,ngs19+ig) = colh2o(lay) * &
- ((fac00(lay) * absa(ind0,ig) + &
- fac10(lay) * absa(ind0+1,ig) + &
- fac01(lay) * absa(ind1,ig) + &
- fac11(lay) * absa(ind1+1,ig)) + &
- selffac(lay) * (selfref(inds,ig) + &
- selffrac(lay) * &
- (selfref(inds+1,ig) - selfref(inds,ig))) + &
- forfac(lay) * (forref(indf,ig) + &
- forfrac(lay) * &
- (forref(indf+1,ig) - forref(indf,ig)))) &
- + colch4(lay) * absch4(ig)
-! ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig)
- taur(lay,ngs19+ig) = tauray
- if (lay .eq. laysolfr) sfluxzen(ngs19+ig) = sfluxref(ig)
- enddo
- enddo
-
-! Upper atmosphere loop
- do lay = laytrop+1, nlayers
- ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(20) + 1
- ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(20) + 1
- indf = indfor(lay)
- tauray = colmol(lay) * rayl
-
- do ig = 1, ng20
- taug(lay,ngs19+ig) = colh2o(lay) * &
- (fac00(lay) * absb(ind0,ig) + &
- fac10(lay) * absb(ind0+1,ig) + &
- fac01(lay) * absb(ind1,ig) + &
- fac11(lay) * absb(ind1+1,ig) + &
- forfac(lay) * (forref(indf,ig) + &
- forfrac(lay) * &
- (forref(indf+1,ig) - forref(indf,ig)))) + &
- colch4(lay) * absch4(ig)
-! ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig)
- taur(lay,ngs19+ig) = tauray
- enddo
- enddo
-
- end subroutine taumol20
-
-!----------------------------------------------------------------------------
- subroutine taumol21
-!----------------------------------------------------------------------------
-!
-! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
-!
-!----------------------------------------------------------------------------
-
-! ------- Modules -------
-
- use parrrsw, only : ng21, ngs20
- use rrsw_kg21, only : absa, ka, absb, kb, forref, selfref, &
- sfluxref, rayl, layreffr, strrat
-
-! ------- Declarations -------
-
-! Local
-
- integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
- real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
- fac110, fac111, fs, speccomb, specmult, specparm, &
- tauray
-
-! Compute the optical depth by interpolating in ln(pressure),
-! temperature, and appropriate species. Below LAYTROP, the water
-! vapor self-continuum is interpolated (in temperature) separately.
-
- laysolfr = laytrop
-
-! Lower atmosphere loop
- do lay = 1, laytrop
- if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
- laysolfr = min(lay+1,laytrop)
- speccomb = colh2o(lay) + strrat*colco2(lay)
- specparm = colh2o(lay)/speccomb
- if (specparm .ge. oneminus) specparm = oneminus
- specmult = 8._rb*(specparm)
- js = 1 + int(specmult)
- fs = mod(specmult, 1._rb )
- fac000 = (1._rb - fs) * fac00(lay)
- fac010 = (1._rb - fs) * fac10(lay)
- fac100 = fs * fac00(lay)
- fac110 = fs * fac10(lay)
- fac001 = (1._rb - fs) * fac01(lay)
- fac011 = (1._rb - fs) * fac11(lay)
- fac101 = fs * fac01(lay)
- fac111 = fs * fac11(lay)
- ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(21) + js
- ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(21) + js
- inds = indself(lay)
- indf = indfor(lay)
- tauray = colmol(lay) * rayl
-
- do ig = 1, ng21
- taug(lay,ngs20+ig) = speccomb * &
- (fac000 * absa(ind0,ig) + &
- fac100 * absa(ind0+1,ig) + &
- fac010 * absa(ind0+9,ig) + &
- fac110 * absa(ind0+10,ig) + &
- fac001 * absa(ind1,ig) + &
- fac101 * absa(ind1+1,ig) + &
- fac011 * absa(ind1+9,ig) + &
- fac111 * absa(ind1+10,ig)) + &
- colh2o(lay) * &
- (selffac(lay) * (selfref(inds,ig) + &
- selffrac(lay) * &
- (selfref(inds+1,ig) - selfref(inds,ig))) + &
- forfac(lay) * (forref(indf,ig) + &
- forfrac(lay) * &
- (forref(indf+1,ig) - forref(indf,ig))))
-! ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig)
- if (lay .eq. laysolfr) sfluxzen(ngs20+ig) = sfluxref(ig,js) &
- + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
- taur(lay,ngs20+ig) = tauray
- enddo
- enddo
-
-! Upper atmosphere loop
- do lay = laytrop+1, nlayers
- speccomb = colh2o(lay) + strrat*colco2(lay)
- specparm = colh2o(lay)/speccomb
- if (specparm .ge. oneminus) specparm = oneminus
- specmult = 4._rb*(specparm)
- js = 1 + int(specmult)
- fs = mod(specmult, 1._rb )
- fac000 = (1._rb - fs) * fac00(lay)
- fac010 = (1._rb - fs) * fac10(lay)
- fac100 = fs * fac00(lay)
- fac110 = fs * fac10(lay)
- fac001 = (1._rb - fs) * fac01(lay)
- fac011 = (1._rb - fs) * fac11(lay)
- fac101 = fs * fac01(lay)
- fac111 = fs * fac11(lay)
- ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(21) + js
- ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(21) + js
- indf = indfor(lay)
- tauray = colmol(lay) * rayl
-
- do ig = 1, ng21
- taug(lay,ngs20+ig) = speccomb * &
- (fac000 * absb(ind0,ig) + &
- fac100 * absb(ind0+1,ig) + &
- fac010 * absb(ind0+5,ig) + &
- fac110 * absb(ind0+6,ig) + &
- fac001 * absb(ind1,ig) + &
- fac101 * absb(ind1+1,ig) + &
- fac011 * absb(ind1+5,ig) + &
- fac111 * absb(ind1+6,ig)) + &
- colh2o(lay) * &
- forfac(lay) * (forref(indf,ig) + &
- forfrac(lay) * &
- (forref(indf+1,ig) - forref(indf,ig)))
-! ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig)
- taur(lay,ngs20+ig) = tauray
- enddo
- enddo
-
- end subroutine taumol21
-
-!----------------------------------------------------------------------------
- subroutine taumol22
-!----------------------------------------------------------------------------
-!
-! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2)
-!
-!----------------------------------------------------------------------------
-
-! ------- Modules -------
-
- use parrrsw, only : ng22, ngs21
- use rrsw_kg22, only : absa, ka, absb, kb, forref, selfref, &
- sfluxref, rayl, layreffr, strrat
-
-! ------- Declarations -------
-
-! Local
-
- integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
- real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
- fac110, fac111, fs, speccomb, specmult, specparm, &
- tauray, o2adj, o2cont
-
-! The following factor is the ratio of total O2 band intensity (lines
-! and Mate continuum) to O2 band intensity (line only). It is needed
-! to adjust the optical depths since the k's include only lines.
- o2adj = 1.6_rb
-
-! Compute the optical depth by interpolating in ln(pressure),
-! temperature, and appropriate species. Below LAYTROP, the water
-! vapor self-continuum is interpolated (in temperature) separately.
-
- laysolfr = laytrop
-
-! Lower atmosphere loop
- do lay = 1, laytrop
- if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
- laysolfr = min(lay+1,laytrop)
- o2cont = 4.35e-4_rb*colo2(lay)/(350.0_rb*2.0_rb)
- speccomb = colh2o(lay) + o2adj*strrat*colo2(lay)
- specparm = colh2o(lay)/speccomb
- if (specparm .ge. oneminus) specparm = oneminus
- specmult = 8._rb*(specparm)
-! odadj = specparm + o2adj * (1._rb - specparm)
- js = 1 + int(specmult)
- fs = mod(specmult, 1._rb )
- fac000 = (1._rb - fs) * fac00(lay)
- fac010 = (1._rb - fs) * fac10(lay)
- fac100 = fs * fac00(lay)
- fac110 = fs * fac10(lay)
- fac001 = (1._rb - fs) * fac01(lay)
- fac011 = (1._rb - fs) * fac11(lay)
- fac101 = fs * fac01(lay)
- fac111 = fs * fac11(lay)
- ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(22) + js
- ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(22) + js
- inds = indself(lay)
- indf = indfor(lay)
- tauray = colmol(lay) * rayl
-
- do ig = 1, ng22
- taug(lay,ngs21+ig) = speccomb * &
- (fac000 * absa(ind0,ig) + &
- fac100 * absa(ind0+1,ig) + &
- fac010 * absa(ind0+9,ig) + &
- fac110 * absa(ind0+10,ig) + &
- fac001 * absa(ind1,ig) + &
- fac101 * absa(ind1+1,ig) + &
- fac011 * absa(ind1+9,ig) + &
- fac111 * absa(ind1+10,ig)) + &
- colh2o(lay) * &
- (selffac(lay) * (selfref(inds,ig) + &
- selffrac(lay) * &
- (selfref(inds+1,ig) - selfref(inds,ig))) + &
- forfac(lay) * (forref(indf,ig) + &
- forfrac(lay) * &
- (forref(indf+1,ig) - forref(indf,ig)))) &
- + o2cont
-! ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig)
- if (lay .eq. laysolfr) sfluxzen(ngs21+ig) = sfluxref(ig,js) &
- + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
- taur(lay,ngs21+ig) = tauray
- enddo
- enddo
-
-! Upper atmosphere loop
- do lay = laytrop+1, nlayers
- o2cont = 4.35e-4_rb*colo2(lay)/(350.0_rb*2.0_rb)
- ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(22) + 1
- ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(22) + 1
- tauray = colmol(lay) * rayl
-
- do ig = 1, ng22
- taug(lay,ngs21+ig) = colo2(lay) * o2adj * &
- (fac00(lay) * absb(ind0,ig) + &
- fac10(lay) * absb(ind0+1,ig) + &
- fac01(lay) * absb(ind1,ig) + &
- fac11(lay) * absb(ind1+1,ig)) + &
- o2cont
-! ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig)
- taur(lay,ngs21+ig) = tauray
- enddo
- enddo
-
- end subroutine taumol22
-
-!----------------------------------------------------------------------------
- subroutine taumol23
-!----------------------------------------------------------------------------
-!
-! band 23: 8050-12850 cm-1 (low - h2o; high - nothing)
-!
-!----------------------------------------------------------------------------
-
-! ------- Modules -------
-
- use parrrsw, only : ng23, ngs22
- use rrsw_kg23, only : absa, ka, forref, selfref, &
- sfluxref, rayl, layreffr, givfac
-
-! ------- Declarations -------
-
-! Local
-
- integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
- real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
- fac110, fac111, fs, speccomb, specmult, specparm, &
- tauray
-
-! Compute the optical depth by interpolating in ln(pressure),
-! temperature, and appropriate species. Below LAYTROP, the water
-! vapor self-continuum is interpolated (in temperature) separately.
-
- laysolfr = laytrop
-
-! Lower atmosphere loop
- do lay = 1, laytrop
- if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
- laysolfr = min(lay+1,laytrop)
- ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(23) + 1
- ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(23) + 1
- inds = indself(lay)
- indf = indfor(lay)
-
- do ig = 1, ng23
- tauray = colmol(lay) * rayl(ig)
- taug(lay,ngs22+ig) = colh2o(lay) * &
- (givfac * (fac00(lay) * absa(ind0,ig) + &
- fac10(lay) * absa(ind0+1,ig) + &
- fac01(lay) * absa(ind1,ig) + &
- fac11(lay) * absa(ind1+1,ig)) + &
- selffac(lay) * (selfref(inds,ig) + &
- selffrac(lay) * &
- (selfref(inds+1,ig) - selfref(inds,ig))) + &
- forfac(lay) * (forref(indf,ig) + &
- forfrac(lay) * &
- (forref(indf+1,ig) - forref(indf,ig))))
-! ssa(lay,ngs22+ig) = tauray/taug(lay,ngs22+ig)
- if (lay .eq. laysolfr) sfluxzen(ngs22+ig) = sfluxref(ig)
- taur(lay,ngs22+ig) = tauray
- enddo
- enddo
-
-! Upper atmosphere loop
- do lay = laytrop+1, nlayers
- do ig = 1, ng23
-! taug(lay,ngs22+ig) = colmol(lay) * rayl(ig)
-! ssa(lay,ngs22+ig) = 1.0_rb
- taug(lay,ngs22+ig) = 0._rb
- taur(lay,ngs22+ig) = colmol(lay) * rayl(ig)
- enddo
- enddo
-
- end subroutine taumol23
-
-!----------------------------------------------------------------------------
- subroutine taumol24
-!----------------------------------------------------------------------------
-!
-! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
-!
-!----------------------------------------------------------------------------
-
-! ------- Modules -------
-
- use parrrsw, only : ng24, ngs23
- use rrsw_kg24, only : absa, ka, absb, kb, forref, selfref, &
- sfluxref, abso3a, abso3b, rayla, raylb, &
- layreffr, strrat
-
-! ------- Declarations -------
-
-! Local
-
- integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
- real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
- fac110, fac111, fs, speccomb, specmult, specparm, &
- tauray
-
-! Compute the optical depth by interpolating in ln(pressure),
-! temperature, and appropriate species. Below LAYTROP, the water
-! vapor self-continuum is interpolated (in temperature) separately.
-
- laysolfr = laytrop
-
-! Lower atmosphere loop
- do lay = 1, laytrop
- if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
- laysolfr = min(lay+1,laytrop)
- speccomb = colh2o(lay) + strrat*colo2(lay)
- specparm = colh2o(lay)/speccomb
- if (specparm .ge. oneminus) specparm = oneminus
- specmult = 8._rb*(specparm)
- js = 1 + int(specmult)
- fs = mod(specmult, 1._rb )
- fac000 = (1._rb - fs) * fac00(lay)
- fac010 = (1._rb - fs) * fac10(lay)
- fac100 = fs * fac00(lay)
- fac110 = fs * fac10(lay)
- fac001 = (1._rb - fs) * fac01(lay)
- fac011 = (1._rb - fs) * fac11(lay)
- fac101 = fs * fac01(lay)
- fac111 = fs * fac11(lay)
- ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(24) + js
- ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(24) + js
- inds = indself(lay)
- indf = indfor(lay)
-
- do ig = 1, ng24
- tauray = colmol(lay) * (rayla(ig,js) + &
- fs * (rayla(ig,js+1) - rayla(ig,js)))
- taug(lay,ngs23+ig) = speccomb * &
- (fac000 * absa(ind0,ig) + &
- fac100 * absa(ind0+1,ig) + &
- fac010 * absa(ind0+9,ig) + &
- fac110 * absa(ind0+10,ig) + &
- fac001 * absa(ind1,ig) + &
- fac101 * absa(ind1+1,ig) + &
- fac011 * absa(ind1+9,ig) + &
- fac111 * absa(ind1+10,ig)) + &
- colo3(lay) * abso3a(ig) + &
- colh2o(lay) * &
- (selffac(lay) * (selfref(inds,ig) + &
- selffrac(lay) * &
- (selfref(inds+1,ig) - selfref(inds,ig))) + &
- forfac(lay) * (forref(indf,ig) + &
- forfrac(lay) * &
- (forref(indf+1,ig) - forref(indf,ig))))
-! ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig)
- if (lay .eq. laysolfr) sfluxzen(ngs23+ig) = sfluxref(ig,js) &
- + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
- taur(lay,ngs23+ig) = tauray
- enddo
- enddo
-
-! Upper atmosphere loop
- do lay = laytrop+1, nlayers
- ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(24) + 1
- ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(24) + 1
-
- do ig = 1, ng24
- tauray = colmol(lay) * raylb(ig)
- taug(lay,ngs23+ig) = colo2(lay) * &
- (fac00(lay) * absb(ind0,ig) + &
- fac10(lay) * absb(ind0+1,ig) + &
- fac01(lay) * absb(ind1,ig) + &
- fac11(lay) * absb(ind1+1,ig)) + &
- colo3(lay) * abso3b(ig)
-! ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig)
- taur(lay,ngs23+ig) = tauray
- enddo
- enddo
-
- end subroutine taumol24
-
-!----------------------------------------------------------------------------
- subroutine taumol25
-!----------------------------------------------------------------------------
-!
-! band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
-!
-!----------------------------------------------------------------------------
-
-! ------- Modules -------
-
- use parrrsw, only : ng25, ngs24
- use rrsw_kg25, only : absa, ka, &
- sfluxref, abso3a, abso3b, rayl, layreffr
-
-! ------- Declarations -------
-
-! Local
-
- integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
- real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
- fac110, fac111, fs, speccomb, specmult, specparm, &
- tauray
-
-! Compute the optical depth by interpolating in ln(pressure),
-! temperature, and appropriate species. Below LAYTROP, the water
-! vapor self-continuum is interpolated (in temperature) separately.
-
- laysolfr = laytrop
-
-! Lower atmosphere loop
- do lay = 1, laytrop
- if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
- laysolfr = min(lay+1,laytrop)
- ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(25) + 1
- ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(25) + 1
-
- do ig = 1, ng25
- tauray = colmol(lay) * rayl(ig)
- taug(lay,ngs24+ig) = colh2o(lay) * &
- (fac00(lay) * absa(ind0,ig) + &
- fac10(lay) * absa(ind0+1,ig) + &
- fac01(lay) * absa(ind1,ig) + &
- fac11(lay) * absa(ind1+1,ig)) + &
- colo3(lay) * abso3a(ig)
-! ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig)
- if (lay .eq. laysolfr) sfluxzen(ngs24+ig) = sfluxref(ig)
- taur(lay,ngs24+ig) = tauray
- enddo
- enddo
-
-! Upper atmosphere loop
- do lay = laytrop+1, nlayers
- do ig = 1, ng25
- tauray = colmol(lay) * rayl(ig)
- taug(lay,ngs24+ig) = colo3(lay) * abso3b(ig)
-! ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig)
- taur(lay,ngs24+ig) = tauray
- enddo
- enddo
-
- end subroutine taumol25
-
-!----------------------------------------------------------------------------
- subroutine taumol26
-!----------------------------------------------------------------------------
-!
-! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
-!
-!----------------------------------------------------------------------------
-
-! ------- Modules -------
-
- use parrrsw, only : ng26, ngs25
- use rrsw_kg26, only : sfluxref, rayl
-
-! ------- Declarations -------
-
-! Local
-
- integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
- real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
- fac110, fac111, fs, speccomb, specmult, specparm, &
- tauray
-
-! Compute the optical depth by interpolating in ln(pressure),
-! temperature, and appropriate species. Below LAYTROP, the water
-! vapor self-continuum is interpolated (in temperature) separately.
-
- laysolfr = laytrop
-
-! Lower atmosphere loop
- do lay = 1, laytrop
- do ig = 1, ng26
-! taug(lay,ngs25+ig) = colmol(lay) * rayl(ig)
-! ssa(lay,ngs25+ig) = 1.0_rb
- if (lay .eq. laysolfr) sfluxzen(ngs25+ig) = sfluxref(ig)
- taug(lay,ngs25+ig) = 0._rb
- taur(lay,ngs25+ig) = colmol(lay) * rayl(ig)
- enddo
- enddo
-
-! Upper atmosphere loop
- do lay = laytrop+1, nlayers
- do ig = 1, ng26
-! taug(lay,ngs25+ig) = colmol(lay) * rayl(ig)
-! ssa(lay,ngs25+ig) = 1.0_rb
- taug(lay,ngs25+ig) = 0._rb
- taur(lay,ngs25+ig) = colmol(lay) * rayl(ig)
- enddo
- enddo
-
- end subroutine taumol26
-
-!----------------------------------------------------------------------------
- subroutine taumol27
-!----------------------------------------------------------------------------
-!
-! band 27: 29000-38000 cm-1 (low - o3; high - o3)
-!
-!----------------------------------------------------------------------------
-
-! ------- Modules -------
-
- use parrrsw, only : ng27, ngs26
- use rrsw_kg27, only : absa, ka, absb, kb, &
- sfluxref, rayl, layreffr, scalekur
-
-! ------- Declarations -------
-
-! Local
-
- integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
- real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
- fac110, fac111, fs, speccomb, specmult, specparm, &
- tauray
-
-! Compute the optical depth by interpolating in ln(pressure),
-! temperature, and appropriate species. Below LAYTROP, the water
-! vapor self-continuum is interpolated (in temperature) separately.
-
-! Lower atmosphere loop
- do lay = 1, laytrop
- ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(27) + 1
- ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(27) + 1
-
- do ig = 1, ng27
- tauray = colmol(lay) * rayl(ig)
- taug(lay,ngs26+ig) = colo3(lay) * &
- (fac00(lay) * absa(ind0,ig) + &
- fac10(lay) * absa(ind0+1,ig) + &
- fac01(lay) * absa(ind1,ig) + &
- fac11(lay) * absa(ind1+1,ig))
-! ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig)
- taur(lay,ngs26+ig) = tauray
- enddo
- enddo
-
- laysolfr = nlayers
-
-! Upper atmosphere loop
- do lay = laytrop+1, nlayers
- if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) &
- laysolfr = lay
- ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(27) + 1
- ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(27) + 1
-
- do ig = 1, ng27
- tauray = colmol(lay) * rayl(ig)
- taug(lay,ngs26+ig) = colo3(lay) * &
- (fac00(lay) * absb(ind0,ig) + &
- fac10(lay) * absb(ind0+1,ig) + &
- fac01(lay) * absb(ind1,ig) + &
- fac11(lay) * absb(ind1+1,ig))
-! ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig)
- if (lay.eq.laysolfr) sfluxzen(ngs26+ig) = scalekur * sfluxref(ig)
- taur(lay,ngs26+ig) = tauray
- enddo
- enddo
-
- end subroutine taumol27
-
-!----------------------------------------------------------------------------
- subroutine taumol28
-!----------------------------------------------------------------------------
-!
-! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2)
-!
-!----------------------------------------------------------------------------
-
-! ------- Modules -------
-
- use parrrsw, only : ng28, ngs27
- use rrsw_kg28, only : absa, ka, absb, kb, &
- sfluxref, rayl, layreffr, strrat
-
-! ------- Declarations -------
-
-! Local
-
- integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
- real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
- fac110, fac111, fs, speccomb, specmult, specparm, &
- tauray
-
-! Compute the optical depth by interpolating in ln(pressure),
-! temperature, and appropriate species. Below LAYTROP, the water
-! vapor self-continuum is interpolated (in temperature) separately.
-
-! Lower atmosphere loop
- do lay = 1, laytrop
- speccomb = colo3(lay) + strrat*colo2(lay)
- specparm = colo3(lay)/speccomb
- if (specparm .ge. oneminus) specparm = oneminus
- specmult = 8._rb*(specparm)
- js = 1 + int(specmult)
- fs = mod(specmult, 1._rb )
- fac000 = (1._rb - fs) * fac00(lay)
- fac010 = (1._rb - fs) * fac10(lay)
- fac100 = fs * fac00(lay)
- fac110 = fs * fac10(lay)
- fac001 = (1._rb - fs) * fac01(lay)
- fac011 = (1._rb - fs) * fac11(lay)
- fac101 = fs * fac01(lay)
- fac111 = fs * fac11(lay)
- ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(28) + js
- ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(28) + js
- tauray = colmol(lay) * rayl
-
- do ig = 1, ng28
- taug(lay,ngs27+ig) = speccomb * &
- (fac000 * absa(ind0,ig) + &
- fac100 * absa(ind0+1,ig) + &
- fac010 * absa(ind0+9,ig) + &
- fac110 * absa(ind0+10,ig) + &
- fac001 * absa(ind1,ig) + &
- fac101 * absa(ind1+1,ig) + &
- fac011 * absa(ind1+9,ig) + &
- fac111 * absa(ind1+10,ig))
-! ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig)
- taur(lay,ngs27+ig) = tauray
- enddo
- enddo
-
- laysolfr = nlayers
-
-! Upper atmosphere loop
- do lay = laytrop+1, nlayers
- if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) &
- laysolfr = lay
- speccomb = colo3(lay) + strrat*colo2(lay)
- specparm = colo3(lay)/speccomb
- if (specparm .ge. oneminus) specparm = oneminus
- specmult = 4._rb*(specparm)
- js = 1 + int(specmult)
- fs = mod(specmult, 1._rb )
- fac000 = (1._rb - fs) * fac00(lay)
- fac010 = (1._rb - fs) * fac10(lay)
- fac100 = fs * fac00(lay)
- fac110 = fs * fac10(lay)
- fac001 = (1._rb - fs) * fac01(lay)
- fac011 = (1._rb - fs) * fac11(lay)
- fac101 = fs * fac01(lay)
- fac111 = fs * fac11(lay)
- ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(28) + js
- ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(28) + js
- tauray = colmol(lay) * rayl
-
- do ig = 1, ng28
- taug(lay,ngs27+ig) = speccomb * &
- (fac000 * absb(ind0,ig) + &
- fac100 * absb(ind0+1,ig) + &
- fac010 * absb(ind0+5,ig) + &
- fac110 * absb(ind0+6,ig) + &
- fac001 * absb(ind1,ig) + &
- fac101 * absb(ind1+1,ig) + &
- fac011 * absb(ind1+5,ig) + &
- fac111 * absb(ind1+6,ig))
-! ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig)
- if (lay .eq. laysolfr) sfluxzen(ngs27+ig) = sfluxref(ig,js) &
- + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
- taur(lay,ngs27+ig) = tauray
- enddo
- enddo
-
- end subroutine taumol28
-
-!----------------------------------------------------------------------------
- subroutine taumol29
-!----------------------------------------------------------------------------
-!
-! band 29: 820-2600 cm-1 (low - h2o; high - co2)
-!
-!----------------------------------------------------------------------------
-
-! ------- Modules -------
-
- use parrrsw, only : ng29, ngs28
- use rrsw_kg29, only : absa, ka, absb, kb, forref, selfref, &
- sfluxref, absh2o, absco2, rayl, layreffr
-
-! ------- Declarations -------
-
-! Local
-
- integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
- real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
- fac110, fac111, fs, speccomb, specmult, specparm, &
- tauray
-
-! Compute the optical depth by interpolating in ln(pressure),
-! temperature, and appropriate species. Below LAYTROP, the water
-! vapor self-continuum is interpolated (in temperature) separately.
-
-! Lower atmosphere loop
- do lay = 1, laytrop
- ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(29) + 1
- ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(29) + 1
- inds = indself(lay)
- indf = indfor(lay)
- tauray = colmol(lay) * rayl
-
- do ig = 1, ng29
- taug(lay,ngs28+ig) = colh2o(lay) * &
- ((fac00(lay) * absa(ind0,ig) + &
- fac10(lay) * absa(ind0+1,ig) + &
- fac01(lay) * absa(ind1,ig) + &
- fac11(lay) * absa(ind1+1,ig)) + &
- selffac(lay) * (selfref(inds,ig) + &
- selffrac(lay) * &
- (selfref(inds+1,ig) - selfref(inds,ig))) + &
- forfac(lay) * (forref(indf,ig) + &
- forfrac(lay) * &
- (forref(indf+1,ig) - forref(indf,ig)))) &
- + colco2(lay) * absco2(ig)
-! ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig)
- taur(lay,ngs28+ig) = tauray
- enddo
- enddo
-
- laysolfr = nlayers
-
-! Upper atmosphere loop
- do lay = laytrop+1, nlayers
- if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) &
- laysolfr = lay
- ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(29) + 1
- ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(29) + 1
- tauray = colmol(lay) * rayl
-
- do ig = 1, ng29
- taug(lay,ngs28+ig) = colco2(lay) * &
- (fac00(lay) * absb(ind0,ig) + &
- fac10(lay) * absb(ind0+1,ig) + &
- fac01(lay) * absb(ind1,ig) + &
- fac11(lay) * absb(ind1+1,ig)) &
- + colh2o(lay) * absh2o(ig)
-! ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig)
- if (lay .eq. laysolfr) sfluxzen(ngs28+ig) = sfluxref(ig)
- taur(lay,ngs28+ig) = tauray
- enddo
- enddo
-
- end subroutine taumol29
-
- end subroutine taumol_sw
-
- end module rrtmg_sw_taumol
-
-! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
-! author: $Author: trn $
-! revision: $Revision: 1.3 $
-! created: $Date: 2009/04/16 19:54:22 $
-
- module rrtmg_sw_init
-
-! --------------------------------------------------------------------------
-! | |
-! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
-! | This software may be used, copied, or redistributed as long as it is |
-! | not sold and this copyright notice is reproduced on each copy made. |
-! | This model is provided as is without any express or implied warranties. |
-! | (http://www.rtweb.aer.com/) |
-! | |
-! --------------------------------------------------------------------------
-
-! ------- Modules -------
- use parkind, only : im => kind_im, rb => kind_rb
- use rrsw_wvn
- use rrtmg_sw_setcoef, only: swatmref
-
- implicit none
-
- contains
-
-! **************************************************************************
- subroutine rrtmg_sw_ini(cpdair)
-! **************************************************************************
-!
-! Original version: Michael J. Iacono; February, 2004
-! Revision for F90 formatting: M. J. Iacono, July, 2006
-!
-! This subroutine performs calculations necessary for the initialization
-! of the shortwave model. Lookup tables are computed for use in the SW
-! radiative transfer, and input absorption coefficient data for each
-! spectral band are reduced from 224 g-point intervals to 112.
-! **************************************************************************
-
- use parrrsw, only : mg, nbndsw, ngptsw
- use rrsw_tbl, only: ntbl, tblint, pade, bpade, tau_tbl, exp_tbl
- use rrsw_vsn, only: hvrini, hnamini
-
- real(kind=rb), intent(in) :: cpdair ! Specific heat capacity of dry air
- ! at constant pressure at 273 K
- ! (J kg-1 K-1)
-
-! ------- Local -------
-
- integer(kind=im) :: ibnd, igc, ig, ind, ipr
- integer(kind=im) :: igcsm, iprsm
- integer(kind=im) :: itr
-
- real(kind=rb) :: wtsum, wtsm(mg)
- real(kind=rb) :: tfn
-
- real(kind=rb), parameter :: expeps = 1.e-20 ! Smallest value for exponential table
-
-! ------- Definitions -------
-! Arrays for 10000-point look-up tables:
-! TAU_TBL Clear-sky optical depth
-! EXP_TBL Exponential lookup table for transmittance
-! PADE Pade approximation constant (= 0.278)
-! BPADE Inverse of the Pade approximation constant
-!
-
-!jm not thread safe hvrini = '$Revision: 1.3 $'
-
-! Initialize model data
- call swdatinit(cpdair)
- call swcmbdat ! g-point interval reduction data
- call swaerpr ! aerosol optical properties
- call swcldpr ! cloud optical properties
- call swatmref ! reference MLS profile
-! Moved to module_ra_rrtmg_sw for WRF
-! call sw_kgb16 ! molecular absorption coefficients
-! call sw_kgb17
-! call sw_kgb18
-! call sw_kgb19
-! call sw_kgb20
-! call sw_kgb21
-! call sw_kgb22
-! call sw_kgb23
-! call sw_kgb24
-! call sw_kgb25
-! call sw_kgb26
-! call sw_kgb27
-! call sw_kgb28
-! call sw_kgb29
-
-! Define exponential lookup tables for transmittance. Tau is
-! computed as a function of the tau transition function, and transmittance
-! is calculated as a function of tau. All tables are computed at intervals
-! of 0.0001. The inverse of the constant used in the Pade approximation to
-! the tau transition function is set to bpade.
-
- exp_tbl(0) = 1.0_rb
- exp_tbl(ntbl) = expeps
- bpade = 1.0_rb / pade
- do itr = 1, ntbl-1
- tfn = float(itr) / float(ntbl)
- tau_tbl = bpade * tfn / (1._rb - tfn)
- exp_tbl(itr) = exp(-tau_tbl)
- if (exp_tbl(itr) .le. expeps) exp_tbl(itr) = expeps
- enddo
-
-! Perform g-point reduction from 16 per band (224 total points) to
-! a band dependent number (112 total points) for all absorption
-! coefficient input data and Planck fraction input data.
-! Compute relative weighting for new g-point combinations.
-
- igcsm = 0
- do ibnd = 1,nbndsw
- iprsm = 0
- if (ngc(ibnd).lt.mg) then
- do igc = 1,ngc(ibnd)
- igcsm = igcsm + 1
- wtsum = 0.
- do ipr = 1, ngn(igcsm)
- iprsm = iprsm + 1
- wtsum = wtsum + wt(iprsm)
- enddo
- wtsm(igc) = wtsum
- enddo
- do ig = 1, ng(ibnd+15)
- ind = (ibnd-1)*mg + ig
- rwgt(ind) = wt(ig)/wtsm(ngm(ind))
- enddo
- else
- do ig = 1, ng(ibnd+15)
- igcsm = igcsm + 1
- ind = (ibnd-1)*mg + ig
- rwgt(ind) = 1.0_rb
- enddo
- endif
- enddo
-
-! Reduce g-points for absorption coefficient data in each LW spectral band.
-
- call cmbgb16s
- call cmbgb17
- call cmbgb18
- call cmbgb19
- call cmbgb20
- call cmbgb21
- call cmbgb22
- call cmbgb23
- call cmbgb24
- call cmbgb25
- call cmbgb26
- call cmbgb27
- call cmbgb28
- call cmbgb29
-
- end subroutine rrtmg_sw_ini
-
-!***************************************************************************
- subroutine swdatinit(cpdair)
-!***************************************************************************
-
-! --------- Modules ----------
-
- use rrsw_con, only: heatfac, grav, planck, boltz, &
- clight, avogad, alosmt, gascon, radcn1, radcn2, &
- sbcnst, secdy, oneminus, pi
- use rrsw_vsn
-
- save
-
- real(kind=rb), intent(in) :: cpdair ! Specific heat capacity of dry air
- ! at constant pressure at 273 K
- ! (J kg-1 K-1)
-
-! Shortwave spectral band limits (wavenumbers)
- wavenum1(:) = (/2600._rb, 3250._rb, 4000._rb, 4650._rb, 5150._rb, 6150._rb, 7700._rb, &
- 8050._rb,12850._rb,16000._rb,22650._rb,29000._rb,38000._rb, 820._rb/)
- wavenum2(:) = (/3250._rb, 4000._rb, 4650._rb, 5150._rb, 6150._rb, 7700._rb, 8050._rb, &
- 12850._rb,16000._rb,22650._rb,29000._rb,38000._rb,50000._rb, 2600._rb/)
- delwave(:) = (/ 650._rb, 750._rb, 650._rb, 500._rb, 1000._rb, 1550._rb, 350._rb, &
- 4800._rb, 3150._rb, 6650._rb, 6350._rb, 9000._rb,12000._rb, 1780._rb/)
-
-! Spectral band information
- ng(:) = (/16,16,16,16,16,16,16,16,16,16,16,16,16,16/)
- nspa(:) = (/9,9,9,9,1,9,9,1,9,1,0,1,9,1/)
- nspb(:) = (/1,5,1,1,1,5,1,0,1,0,0,1,5,1/)
-
-! Fundamental physical constants from NIST 2002
-
- grav = 9.8066_rb ! Acceleration of gravity
- ! (m s-2)
- planck = 6.62606876e-27_rb ! Planck constant
- ! (ergs s; g cm2 s-1)
- boltz = 1.3806503e-16_rb ! Boltzmann constant
- ! (ergs K-1; g cm2 s-2 K-1)
- clight = 2.99792458e+10_rb ! Speed of light in a vacuum
- ! (cm s-1)
- avogad = 6.02214199e+23_rb ! Avogadro constant
- ! (mol-1)
- alosmt = 2.6867775e+19_rb ! Loschmidt constant
- ! (cm-3)
- gascon = 8.31447200e+07_rb ! Molar gas constant
- ! (ergs mol-1 K-1)
- radcn1 = 1.191042772e-12_rb ! First radiation constant
- ! (W cm2 sr-1)
- radcn2 = 1.4387752_rb ! Second radiation constant
- ! (cm K)
- sbcnst = 5.670400e-04_rb ! Stefan-Boltzmann constant
- ! (W cm-2 K-4)
- secdy = 8.6400e4_rb ! Number of seconds per day
- ! (s d-1)
-
-!jm 20141107 moved here for thread safety
- oneminus = 1.0_rb - 1.e-06_rb ! zepsec
- pi = 2._rb * asin(1._rb)
-
-!
-! units are generally cgs
-!
-! The first and second radiation constants are taken from NIST.
-! They were previously obtained from the relations:
-! radcn1 = 2.*planck*clight*clight*1.e-07
-! radcn2 = planck*clight/boltz
-
-! Heatfac is the factor by which delta-flux / delta-pressure is
-! multiplied, with flux in W/m-2 and pressure in mbar, to get
-! the heating rate in units of degrees/day. It is equal to:
-! Original value:
-! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
-! Here, cpdair (1.004) is in units of J g-1 K-1, and the
-! constant (1.e-5) converts mb to Pa and g-1 to kg-1.
-! = (9.8066)(86400)(1e-5)/(1.004)
-! heatfac = 8.4391_rb
-!
-! Modified value for consistency with CAM3:
-! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
-! Here, cpdair (1.00464) is in units of J g-1 K-1, and the
-! constant (1.e-5) converts mb to Pa and g-1 to kg-1.
-! = (9.80616)(86400)(1e-5)/(1.00464)
-! heatfac = 8.43339130434_rb
-!
-! Calculated value (from constants above and input cpdair)
-! (grav) x (#sec/day) / (specific heat of dry air at const. p x 1.e2)
-! Here, cpdair is in units of J kg-1 K-1, and the constant (1.e2)
-! converts mb to Pa when heatfac is multiplied by W m-2 mb-1.
- heatfac = grav * secdy / (cpdair * 1.e2_rb)
-
- end subroutine swdatinit
-
-!***************************************************************************
- subroutine swcmbdat
-!***************************************************************************
-
- save
-
-! ------- Definitions -------
-! Arrays for the g-point reduction from 224 to 112 for the 16 LW bands:
-! This mapping from 224 to 112 points has been carefully selected to
-! minimize the effect on the resulting fluxes and cooling rates, and
-! caution should be used if the mapping is modified. The full 224
-! g-point set can be restored with ngpt=224, ngc=16*16, ngn=224*1., etc.
-! ngpt The total number of new g-points
-! ngc The number of new g-points in each band
-! ngs The cumulative sum of new g-points for each band
-! ngm The index of each new g-point relative to the original
-! 16 g-points for each band.
-! ngn The number of original g-points that are combined to make
-! each new g-point in each band.
-! ngb The band index for each new g-point.
-! wt RRTM weights for 16 g-points.
-
-! Use this set for 112 quadrature point (g-point) model
-! ------- Data statements -------
- ngc(:) = (/ 6,12, 8, 8,10,10, 2,10, 8, 6, 6, 8, 6,12 /)
- ngs(:) = (/ 6,18,26,34,44,54,56,66,74,80,86,94,100,112 /)
- ngm(:) = (/ 1,1,2,2,3,3,4,4,5,5,5,5,6,6,6,6, & ! band 16
- 1,2,3,4,5,6,6,7,8,8,9,10,10,11,12,12, & ! band 17
- 1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, & ! band 18
- 1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, & ! band 19
- 1,2,3,4,5,6,7,8,9,9,10,10,10,10,10,10, & ! band 20
- 1,2,3,4,5,6,7,8,9,9,10,10,10,10,10,10, & ! band 21
- 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, & ! band 22
- 1,1,2,2,3,4,5,6,7,8,9,9,10,10,10,10, & ! band 23
- 1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! band 24
- 1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, & ! band 25
- 1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, & ! band 26
- 1,2,3,4,5,6,7,7,7,7,8,8,8,8,8,8, & ! band 27
- 1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, & ! band 28
- 1,2,3,4,5,5,6,6,7,7,8,8,9,10,11,12 /) ! band 29
- ngn(:) = (/ 2,2,2,2,4,4, & ! band 16
- 1,1,1,1,1,2,1,2,1,2,1,2, & ! band 17
- 1,1,1,1,2,2,4,4, & ! band 18
- 1,1,1,1,2,2,4,4, & ! band 19
- 1,1,1,1,1,1,1,1,2,6, & ! band 20
- 1,1,1,1,1,1,1,1,2,6, & ! band 21
- 8,8, & ! band 22
- 2,2,1,1,1,1,1,1,2,4, & ! band 23
- 2,2,2,2,2,2,2,2, & ! band 24
- 1,1,2,2,4,6, & ! band 25
- 1,1,2,2,4,6, & ! band 26
- 1,1,1,1,1,1,4,6, & ! band 27
- 1,1,2,2,4,6, & ! band 28
- 1,1,1,1,2,2,2,2,1,1,1,1 /) ! band 29
- ngb(:) = (/ 16,16,16,16,16,16, & ! band 16
- 17,17,17,17,17,17,17,17,17,17,17,17, & ! band 17
- 18,18,18,18,18,18,18,18, & ! band 18
- 19,19,19,19,19,19,19,19, & ! band 19
- 20,20,20,20,20,20,20,20,20,20, & ! band 20
- 21,21,21,21,21,21,21,21,21,21, & ! band 21
- 22,22, & ! band 22
- 23,23,23,23,23,23,23,23,23,23, & ! band 23
- 24,24,24,24,24,24,24,24, & ! band 24
- 25,25,25,25,25,25, & ! band 25
- 26,26,26,26,26,26, & ! band 26
- 27,27,27,27,27,27,27,27, & ! band 27
- 28,28,28,28,28,28, & ! band 28
- 29,29,29,29,29,29,29,29,29,29,29,29 /) ! band 29
-
-! Use this set for full 224 quadrature point (g-point) model
-! ------- Data statements -------
-! ngc(:) = (/ 16,16,16,16,16,16,16,16,16,16,16,16,16,16 /)
-! ngs(:) = (/ 16,32,48,64,80,96,112,128,144,160,176,192,208,224 /)
-! ngm(:) = (/ 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 16
-! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 17
-! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 18
-! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 19
-! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 20
-! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 21
-! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 22
-! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 23
-! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 24
-! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 25
-! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 26
-! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 27
-! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 28
-! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16 /) ! band 29
-! ngn(:) = (/ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 16
-! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 17
-! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 18
-! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 19
-! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 20
-! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 21
-! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 22
-! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 23
-! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 24
-! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 25
-! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 26
-! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 27
-! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 28
-! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 /) ! band 29
-! ngb(:) = (/ 16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16, & ! band 16
-! 17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17, & ! band 17
-! 18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18, & ! band 18
-! 19,19,19,19,19,19,19,19,19,19,19,19,19,19,19,19, & ! band 19
-! 20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20, & ! band 20
-! 21,21,21,21,21,21,21,21,21,21,21,21,21,21,21,21, & ! band 21
-! 22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22, & ! band 22
-! 23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23, & ! band 23
-! 24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, & ! band 24
-! 25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25, & ! band 25
-! 26,26,26,26,26,26,26,26,26,26,26,26,26,26,26,26, & ! band 26
-! 27,27,27,27,27,27,27,27,27,27,27,27,27,27,27,27, & ! band 27
-! 28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28, & ! band 28
-! 29,29,29,29,29,29,29,29,29,29,29,29,29,29,29,29 /) ! band 29
-
-
- wt(:) = (/ 0.1527534276_rb, 0.1491729617_rb, 0.1420961469_rb, &
- 0.1316886544_rb, 0.1181945205_rb, 0.1019300893_rb, &
- 0.0832767040_rb, 0.0626720116_rb, 0.0424925000_rb, &
- 0.0046269894_rb, 0.0038279891_rb, 0.0030260086_rb, &
- 0.0022199750_rb, 0.0014140010_rb, 0.0005330000_rb, &
- 0.0000750000_rb /)
-
- end subroutine swcmbdat
-
-!***************************************************************************
- subroutine swaerpr
-!***************************************************************************
-
-! Purpose: Define spectral aerosol properties for six ECMWF aerosol types
-! as used in the ECMWF IFS model (see module rrsw_aer.F90 for details)
-!
-! Original: Defined for rrtmg_sw 14 spectral bands, JJMorcrette, ECMWF Feb 2003
-! Revision: Reformatted for consistency with rrtmg_lw, MJIacono, AER, Jul 2006
-
- use rrsw_aer, only : rsrtaua, rsrpiza, rsrasya
-
- save
-
- rsrtaua( 1, :) = (/ &
- 0.10849_rb, 0.66699_rb, 0.65255_rb, 0.11600_rb, 0.06529_rb, 0.04468_rb/)
- rsrtaua( 2, :) = (/ &
- 0.10849_rb, 0.66699_rb, 0.65255_rb, 0.11600_rb, 0.06529_rb, 0.04468_rb/)
- rsrtaua( 3, :) = (/ &
- 0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
- rsrtaua( 4, :) = (/ &
- 0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
- rsrtaua( 5, :) = (/ &
- 0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
- rsrtaua( 6, :) = (/ &
- 0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
- rsrtaua( 7, :) = (/ &
- 0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
- rsrtaua( 8, :) = (/ &
- 0.52838_rb, 0.93285_rb, 0.93449_rb, 0.53078_rb, 0.67148_rb, 0.46608_rb/)
- rsrtaua( 9, :) = (/ &
- 0.52838_rb, 0.93285_rb, 0.93449_rb, 0.53078_rb, 0.67148_rb, 0.46608_rb/)
- rsrtaua(10, :) = (/ &
- 1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/)
- rsrtaua(11, :) = (/ &
- 1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/)
- rsrtaua(12, :) = (/ &
- 1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/)
- rsrtaua(13, :) = (/ &
- 1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/)
- rsrtaua(14, :) = (/ &
- 0.10849_rb, 0.66699_rb, 0.65255_rb, 0.11600_rb, 0.06529_rb, 0.04468_rb/)
-
- rsrpiza( 1, :) = (/ &
- .5230504_rb, .7868518_rb, .8531531_rb, .4048149_rb, .8748231_rb, .2355667_rb/)
- rsrpiza( 2, :) = (/ &
- .5230504_rb, .7868518_rb, .8531531_rb, .4048149_rb, .8748231_rb, .2355667_rb/)
- rsrpiza( 3, :) = (/ &
- .8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, .9467578_rb, .9955938_rb/)
- rsrpiza( 4, :) = (/ &
- .8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, .9467578_rb, .9955938_rb/)
- rsrpiza( 5, :) = (/ &
- .8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, .9467578_rb, .9955938_rb/)
- rsrpiza( 6, :) = (/ &
- .8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, .9467578_rb, .9955938_rb/)
- rsrpiza( 7, :) = (/ &
- .8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, .9467578_rb, .9955938_rb/)
- rsrpiza( 8, :) = (/ &
- .8970131_rb, .9984940_rb, .9245594_rb, .7768385_rb, .9532763_rb, .9999999_rb/)
- rsrpiza( 9, :) = (/ &
- .8970131_rb, .9984940_rb, .9245594_rb, .7768385_rb, .9532763_rb, .9999999_rb/)
- rsrpiza(10, :) = (/ &
- .9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb, .9401905_rb, .9999999_rb/)
- rsrpiza(11, :) = (/ &
- .9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb, .9401905_rb, .9999999_rb/)
- rsrpiza(12, :) = (/ &
- .9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb, .9401905_rb, .9999999_rb/)
- rsrpiza(13, :) = (/ &
- .9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb, .9401905_rb, .9999999_rb/)
- rsrpiza(14, :) = (/ &
- .5230504_rb, .7868518_rb, .8531531_rb, .4048149_rb, .8748231_rb, .2355667_rb/)
-
- rsrasya( 1, :) = (/ &
- 0.700610_rb, 0.818871_rb, 0.702399_rb, 0.689886_rb, .4629866_rb, .1907639_rb/)
- rsrasya( 2, :) = (/ &
- 0.700610_rb, 0.818871_rb, 0.702399_rb, 0.689886_rb, .4629866_rb, .1907639_rb/)
- rsrasya( 3, :) = (/ &
- 0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, .6105750_rb, .4760794_rb/)
- rsrasya( 4, :) = (/ &
- 0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, .6105750_rb, .4760794_rb/)
- rsrasya( 5, :) = (/ &
- 0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, .6105750_rb, .4760794_rb/)
- rsrasya( 6, :) = (/ &
- 0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, .6105750_rb, .4760794_rb/)
- rsrasya( 7, :) = (/ &
- 0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, .6105750_rb, .4760794_rb/)
- rsrasya( 8, :) = (/ &
- 0.668431_rb, 0.788530_rb, 0.698682_rb, 0.657422_rb, .6735182_rb, .6519706_rb/)
- rsrasya( 9, :) = (/ &
- 0.668431_rb, 0.788530_rb, 0.698682_rb, 0.657422_rb, .6735182_rb, .6519706_rb/)
- rsrasya(10, :) = (/ &
- 0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb, .7008249_rb, .7270548_rb/)
- rsrasya(11, :) = (/ &
- 0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb, .7008249_rb, .7270548_rb/)
- rsrasya(12, :) = (/ &
- 0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb, .7008249_rb, .7270548_rb/)
- rsrasya(13, :) = (/ &
- 0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb, .7008249_rb, .7270548_rb/)
- rsrasya(14, :) = (/ &
- 0.700610_rb, 0.818871_rb, 0.702399_rb, 0.689886_rb, .4629866_rb, .1907639_rb/)
-
- end subroutine swaerpr
-
-!***************************************************************************
- subroutine cmbgb16s
-!***************************************************************************
-!
-! Original version: MJIacono; July 1998
-! Revision for RRTM_SW: MJIacono; November 2002
-! Revision for RRTMG_SW: MJIacono; December 2003
-! Revision for F90 reformatting: MJIacono; July 2006
-!
-! The subroutines CMBGB16->CMBGB29 input the absorption coefficient
-! data for each band, which are defined for 16 g-points and 14 spectral
-! bands. The data are combined with appropriate weighting following the
-! g-point mapping arrays specified in RRTMG_SW_INIT. Solar source
-! function data in array SFLUXREF are combined without weighting. All
-! g-point reduced data are put into new arrays for use in RRTMG_SW.
-!
-! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4)
-!
-!-----------------------------------------------------------------------
-
- use rrsw_kg16, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
- absa, ka, absb, kb, selfref, forref, sfluxref
-
-! ------- Local -------
- integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
- real(kind=rb) :: sumk, sumf
-
-
- do jn = 1,9
- do jt = 1,5
- do jp = 1,13
- iprsm = 0
- do igc = 1,ngc(1)
- sumk = 0.
- do ipr = 1, ngn(igc)
- iprsm = iprsm + 1
- sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm)
- enddo
- ka(jn,jt,jp,igc) = sumk
- enddo
- enddo
- enddo
- enddo
-
- do jt = 1,5
- do jp = 13,59
- iprsm = 0
- do igc = 1,ngc(1)
- sumk = 0.
- do ipr = 1, ngn(igc)
- iprsm = iprsm + 1
- sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm)
- enddo
- kb(jt,jp,igc) = sumk
- enddo
- enddo
- enddo
-
- do jt = 1,10
- iprsm = 0
- do igc = 1,ngc(1)
- sumk = 0.
- do ipr = 1, ngn(igc)
- iprsm = iprsm + 1
- sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm)
- enddo
- selfref(jt,igc) = sumk
- enddo
- enddo
-
- do jt = 1,3
- iprsm = 0
- do igc = 1,ngc(1)
- sumk = 0.
- do ipr = 1, ngn(igc)
- iprsm = iprsm + 1
- sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm)
- enddo
- forref(jt,igc) = sumk
- enddo
- enddo
-
- iprsm = 0
- do igc = 1,ngc(1)
- sumf = 0.
- do ipr = 1, ngn(igc)
- iprsm = iprsm + 1
- sumf = sumf + sfluxrefo(iprsm)
- enddo
- sfluxref(igc) = sumf
- enddo
-
- end subroutine cmbgb16s
-
-!***************************************************************************
- subroutine cmbgb17
-!***************************************************************************
-!
-! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
-!-----------------------------------------------------------------------
-
- use rrsw_kg17, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
- absa, ka, absb, kb, selfref, forref, sfluxref
-
-! ------- Local -------
- integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
- real(kind=rb) :: sumk, sumf
-
-
- do jn = 1,9
- do jt = 1,5
- do jp = 1,13
- iprsm = 0
- do igc = 1,ngc(2)
- sumk = 0.
- do ipr = 1, ngn(ngs(1)+igc)
- iprsm = iprsm + 1
- sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+16)
- enddo
- ka(jn,jt,jp,igc) = sumk
- enddo
- enddo
- enddo
- enddo
-
- do jn = 1,5
- do jt = 1,5
- do jp = 13,59
- iprsm = 0
- do igc = 1,ngc(2)
- sumk = 0.
- do ipr = 1, ngn(ngs(1)+igc)
- iprsm = iprsm + 1
- sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+16)
- enddo
- kb(jn,jt,jp,igc) = sumk
- enddo
- enddo
- enddo
- enddo
-
- do jt = 1,10
- iprsm = 0
- do igc = 1,ngc(2)
- sumk = 0.
- do ipr = 1, ngn(ngs(1)+igc)
- iprsm = iprsm + 1
- sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+16)
- enddo
- selfref(jt,igc) = sumk
- enddo
- enddo
-
- do jt = 1,4
- iprsm = 0
- do igc = 1,ngc(2)
- sumk = 0.
- do ipr = 1, ngn(ngs(1)+igc)
- iprsm = iprsm + 1
- sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+16)
- enddo
- forref(jt,igc) = sumk
- enddo
- enddo
-
- do jp = 1,5
- iprsm = 0
- do igc = 1,ngc(2)
- sumf = 0.
- do ipr = 1, ngn(ngs(1)+igc)
- iprsm = iprsm + 1
- sumf = sumf + sfluxrefo(iprsm,jp)
- enddo
- sfluxref(igc,jp) = sumf
- enddo
- enddo
-
- end subroutine cmbgb17
-
-!***************************************************************************
- subroutine cmbgb18
-!***************************************************************************
-!
-! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4)
-!-----------------------------------------------------------------------
-
- use rrsw_kg18, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
- absa, ka, absb, kb, selfref, forref, sfluxref
-
-! ------- Local -------
- integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
- real(kind=rb) :: sumk, sumf
-
-
- do jn = 1,9
- do jt = 1,5
- do jp = 1,13
- iprsm = 0
- do igc = 1,ngc(3)
- sumk = 0.
- do ipr = 1, ngn(ngs(2)+igc)
- iprsm = iprsm + 1
- sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+32)
- enddo
- ka(jn,jt,jp,igc) = sumk
- enddo
- enddo
- enddo
- enddo
-
- do jt = 1,5
- do jp = 13,59
- iprsm = 0
- do igc = 1,ngc(3)
- sumk = 0.
- do ipr = 1, ngn(ngs(2)+igc)
- iprsm = iprsm + 1
- sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+32)
- enddo
- kb(jt,jp,igc) = sumk
- enddo
- enddo
- enddo
-
- do jt = 1,10
- iprsm = 0
- do igc = 1,ngc(3)
- sumk = 0.
- do ipr = 1, ngn(ngs(2)+igc)
- iprsm = iprsm + 1
- sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+32)
- enddo
- selfref(jt,igc) = sumk
- enddo
- enddo
-
- do jt = 1,3
- iprsm = 0
- do igc = 1,ngc(3)
- sumk = 0.
- do ipr = 1, ngn(ngs(2)+igc)
- iprsm = iprsm + 1
- sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+32)
- enddo
- forref(jt,igc) = sumk
- enddo
- enddo
-
- do jp = 1,9
- iprsm = 0
- do igc = 1,ngc(3)
- sumf = 0.
- do ipr = 1, ngn(ngs(2)+igc)
- iprsm = iprsm + 1
- sumf = sumf + sfluxrefo(iprsm,jp)
- enddo
- sfluxref(igc,jp) = sumf
- enddo
- enddo
-
- end subroutine cmbgb18
-
-!***************************************************************************
- subroutine cmbgb19
-!***************************************************************************
-!
-! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2)
-!-----------------------------------------------------------------------
-
- use rrsw_kg19, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
- absa, ka, absb, kb, selfref, forref, sfluxref
-
-! ------- Local -------
- integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
- real(kind=rb) :: sumk, sumf
-
-
- do jn = 1,9
- do jt = 1,5
- do jp = 1,13
- iprsm = 0
- do igc = 1,ngc(4)
- sumk = 0.
- do ipr = 1, ngn(ngs(3)+igc)
- iprsm = iprsm + 1
- sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+48)
- enddo
- ka(jn,jt,jp,igc) = sumk
- enddo
- enddo
- enddo
- enddo
-
- do jt = 1,5
- do jp = 13,59
- iprsm = 0
- do igc = 1,ngc(4)
- sumk = 0.
- do ipr = 1, ngn(ngs(3)+igc)
- iprsm = iprsm + 1
- sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+48)
- enddo
- kb(jt,jp,igc) = sumk
- enddo
- enddo
- enddo
-
- do jt = 1,10
- iprsm = 0
- do igc = 1,ngc(4)
- sumk = 0.
- do ipr = 1, ngn(ngs(3)+igc)
- iprsm = iprsm + 1
- sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+48)
- enddo
- selfref(jt,igc) = sumk
- enddo
- enddo
-
- do jt = 1,3
- iprsm = 0
- do igc = 1,ngc(4)
- sumk = 0.
- do ipr = 1, ngn(ngs(3)+igc)
- iprsm = iprsm + 1
- sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+48)
- enddo
- forref(jt,igc) = sumk
- enddo
- enddo
-
- do jp = 1,9
- iprsm = 0
- do igc = 1,ngc(4)
- sumf = 0.
- do ipr = 1, ngn(ngs(3)+igc)
- iprsm = iprsm + 1
- sumf = sumf + sfluxrefo(iprsm,jp)
- enddo
- sfluxref(igc,jp) = sumf
- enddo
- enddo
-
- end subroutine cmbgb19
-
-!***************************************************************************
- subroutine cmbgb20
-!***************************************************************************
-!
-! band 20: 5150-6150 cm-1 (low - h2o; high - h2o)
-!-----------------------------------------------------------------------
-
- use rrsw_kg20, only : kao, kbo, selfrefo, forrefo, sfluxrefo, absch4o, &
- absa, ka, absb, kb, selfref, forref, sfluxref, absch4
-
-! ------- Local -------
- integer(kind=im) :: jt, jp, igc, ipr, iprsm
- real(kind=rb) :: sumk, sumf1, sumf2
-
-
- do jt = 1,5
- do jp = 1,13
- iprsm = 0
- do igc = 1,ngc(5)
- sumk = 0.
- do ipr = 1, ngn(ngs(4)+igc)
- iprsm = iprsm + 1
- sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+64)
- enddo
- ka(jt,jp,igc) = sumk
- enddo
- enddo
- do jp = 13,59
- iprsm = 0
- do igc = 1,ngc(5)
- sumk = 0.
- do ipr = 1, ngn(ngs(4)+igc)
- iprsm = iprsm + 1
- sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+64)
- enddo
- kb(jt,jp,igc) = sumk
- enddo
- enddo
- enddo
-
- do jt = 1,10
- iprsm = 0
- do igc = 1,ngc(5)
- sumk = 0.
- do ipr = 1, ngn(ngs(4)+igc)
- iprsm = iprsm + 1
- sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+64)
- enddo
- selfref(jt,igc) = sumk
- enddo
- enddo
-
- do jt = 1,4
- iprsm = 0
- do igc = 1,ngc(5)
- sumk = 0.
- do ipr = 1, ngn(ngs(4)+igc)
- iprsm = iprsm + 1
- sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+64)
- enddo
- forref(jt,igc) = sumk
- enddo
- enddo
-
- iprsm = 0
- do igc = 1,ngc(5)
- sumf1 = 0.
- sumf2 = 0.
- do ipr = 1, ngn(ngs(4)+igc)
- iprsm = iprsm + 1
- sumf1 = sumf1 + sfluxrefo(iprsm)
- sumf2 = sumf2 + absch4o(iprsm)*rwgt(iprsm+64)
- enddo
- sfluxref(igc) = sumf1
- absch4(igc) = sumf2
- enddo
-
- end subroutine cmbgb20
-
-!***************************************************************************
- subroutine cmbgb21
-!***************************************************************************
-!
-! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
-!-----------------------------------------------------------------------
-
- use rrsw_kg21, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
- absa, ka, absb, kb, selfref, forref, sfluxref
-
-! ------- Local -------
- integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
- real(kind=rb) :: sumk, sumf
-
-
- do jn = 1,9
- do jt = 1,5
- do jp = 1,13
- iprsm = 0
- do igc = 1,ngc(6)
- sumk = 0.
- do ipr = 1, ngn(ngs(5)+igc)
- iprsm = iprsm + 1
- sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+80)
- enddo
- ka(jn,jt,jp,igc) = sumk
- enddo
- enddo
- enddo
- enddo
-
- do jn = 1,5
- do jt = 1,5
- do jp = 13,59
- iprsm = 0
- do igc = 1,ngc(6)
- sumk = 0.
- do ipr = 1, ngn(ngs(5)+igc)
- iprsm = iprsm + 1
- sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+80)
- enddo
- kb(jn,jt,jp,igc) = sumk
- enddo
- enddo
- enddo
- enddo
-
- do jt = 1,10
- iprsm = 0
- do igc = 1,ngc(6)
- sumk = 0.
- do ipr = 1, ngn(ngs(5)+igc)
- iprsm = iprsm + 1
- sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+80)
- enddo
- selfref(jt,igc) = sumk
- enddo
- enddo
-
- do jt = 1,4
- iprsm = 0
- do igc = 1,ngc(6)
- sumk = 0.
- do ipr = 1, ngn(ngs(5)+igc)
- iprsm = iprsm + 1
- sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+80)
- enddo
- forref(jt,igc) = sumk
- enddo
- enddo
-
- do jp = 1,9
- iprsm = 0
- do igc = 1,ngc(6)
- sumf = 0.
- do ipr = 1, ngn(ngs(5)+igc)
- iprsm = iprsm + 1
- sumf = sumf + sfluxrefo(iprsm,jp)
- enddo
- sfluxref(igc,jp) = sumf
- enddo
- enddo
-
- end subroutine cmbgb21
-
-!***************************************************************************
- subroutine cmbgb22
-!***************************************************************************
-!
-! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2)
-!-----------------------------------------------------------------------
-
- use rrsw_kg22, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
- absa, ka, absb, kb, selfref, forref, sfluxref
-
-! ------- Local -------
- integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
- real(kind=rb) :: sumk, sumf
-
-
- do jn = 1,9
- do jt = 1,5
- do jp = 1,13
- iprsm = 0
- do igc = 1,ngc(7)
- sumk = 0.
- do ipr = 1, ngn(ngs(6)+igc)
- iprsm = iprsm + 1
- sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+96)
- enddo
- ka(jn,jt,jp,igc) = sumk
- enddo
- enddo
- enddo
- enddo
-
- do jt = 1,5
- do jp = 13,59
- iprsm = 0
- do igc = 1,ngc(7)
- sumk = 0.
- do ipr = 1, ngn(ngs(6)+igc)
- iprsm = iprsm + 1
- sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+96)
- enddo
- kb(jt,jp,igc) = sumk
- enddo
- enddo
- enddo
-
- do jt = 1,10
- iprsm = 0
- do igc = 1,ngc(7)
- sumk = 0.
- do ipr = 1, ngn(ngs(6)+igc)
- iprsm = iprsm + 1
- sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+96)
- enddo
- selfref(jt,igc) = sumk
- enddo
- enddo
-
- do jt = 1,3
- iprsm = 0
- do igc = 1,ngc(7)
- sumk = 0.
- do ipr = 1, ngn(ngs(6)+igc)
- iprsm = iprsm + 1
- sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+96)
- enddo
- forref(jt,igc) = sumk
- enddo
- enddo
-
- do jp = 1,9
- iprsm = 0
- do igc = 1,ngc(7)
- sumf = 0.
- do ipr = 1, ngn(ngs(6)+igc)
- iprsm = iprsm + 1
- sumf = sumf + sfluxrefo(iprsm,jp)
- enddo
- sfluxref(igc,jp) = sumf
- enddo
- enddo
-
- end subroutine cmbgb22
-
-!***************************************************************************
- subroutine cmbgb23
-!***************************************************************************
-!
-! band 23: 8050-12850 cm-1 (low - h2o; high - nothing)
-!-----------------------------------------------------------------------
-
- use rrsw_kg23, only : kao, selfrefo, forrefo, sfluxrefo, raylo, &
- absa, ka, selfref, forref, sfluxref, rayl
-
-! ------- Local -------
- integer(kind=im) :: jt, jp, igc, ipr, iprsm
- real(kind=rb) :: sumk, sumf1, sumf2
-
-
- do jt = 1,5
- do jp = 1,13
- iprsm = 0
- do igc = 1,ngc(8)
- sumk = 0.
- do ipr = 1, ngn(ngs(7)+igc)
- iprsm = iprsm + 1
- sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+112)
- enddo
- ka(jt,jp,igc) = sumk
- enddo
- enddo
- enddo
-
- do jt = 1,10
- iprsm = 0
- do igc = 1,ngc(8)
- sumk = 0.
- do ipr = 1, ngn(ngs(7)+igc)
- iprsm = iprsm + 1
- sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+112)
- enddo
- selfref(jt,igc) = sumk
- enddo
- enddo
-
- do jt = 1,3
- iprsm = 0
- do igc = 1,ngc(8)
- sumk = 0.
- do ipr = 1, ngn(ngs(7)+igc)
- iprsm = iprsm + 1
- sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+112)
- enddo
- forref(jt,igc) = sumk
- enddo
- enddo
-
- iprsm = 0
- do igc = 1,ngc(8)
- sumf1 = 0.
- sumf2 = 0.
- do ipr = 1, ngn(ngs(7)+igc)
- iprsm = iprsm + 1
- sumf1 = sumf1 + sfluxrefo(iprsm)
- sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+112)
- enddo
- sfluxref(igc) = sumf1
- rayl(igc) = sumf2
- enddo
-
- end subroutine cmbgb23
-
-!***************************************************************************
- subroutine cmbgb24
-!***************************************************************************
-!
-! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
-!-----------------------------------------------------------------------
-
- use rrsw_kg24, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
- abso3ao, abso3bo, raylao, raylbo, &
- absa, ka, absb, kb, selfref, forref, sfluxref, &
- abso3a, abso3b, rayla, raylb
-
-! ------- Local -------
- integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
- real(kind=rb) :: sumk, sumf1, sumf2, sumf3
-
-
- do jn = 1,9
- do jt = 1,5
- do jp = 1,13
- iprsm = 0
- do igc = 1,ngc(9)
- sumk = 0.
- do ipr = 1, ngn(ngs(8)+igc)
- iprsm = iprsm + 1
- sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+128)
- enddo
- ka(jn,jt,jp,igc) = sumk
- enddo
- enddo
- enddo
- enddo
-
- do jt = 1,5
- do jp = 13,59
- iprsm = 0
- do igc = 1,ngc(9)
- sumk = 0.
- do ipr = 1, ngn(ngs(8)+igc)
- iprsm = iprsm + 1
- sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+128)
- enddo
- kb(jt,jp,igc) = sumk
- enddo
- enddo
- enddo
-
- do jt = 1,10
- iprsm = 0
- do igc = 1,ngc(9)
- sumk = 0.
- do ipr = 1, ngn(ngs(8)+igc)
- iprsm = iprsm + 1
- sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+128)
- enddo
- selfref(jt,igc) = sumk
- enddo
- enddo
-
- do jt = 1,3
- iprsm = 0
- do igc = 1,ngc(9)
- sumk = 0.
- do ipr = 1, ngn(ngs(8)+igc)
- iprsm = iprsm + 1
- sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+128)
- enddo
- forref(jt,igc) = sumk
- enddo
- enddo
-
- iprsm = 0
- do igc = 1,ngc(9)
- sumf1 = 0.
- sumf2 = 0.
- sumf3 = 0.
- do ipr = 1, ngn(ngs(8)+igc)
- iprsm = iprsm + 1
- sumf1 = sumf1 + raylbo(iprsm)*rwgt(iprsm+128)
- sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+128)
- sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+128)
- enddo
- raylb(igc) = sumf1
- abso3a(igc) = sumf2
- abso3b(igc) = sumf3
- enddo
-
- do jp = 1,9
- iprsm = 0
- do igc = 1,ngc(9)
- sumf1 = 0.
- sumf2 = 0.
- do ipr = 1, ngn(ngs(8)+igc)
- iprsm = iprsm + 1
- sumf1 = sumf1 + sfluxrefo(iprsm,jp)
- sumf2 = sumf2 + raylao(iprsm,jp)*rwgt(iprsm+128)
- enddo
- sfluxref(igc,jp) = sumf1
- rayla(igc,jp) = sumf2
- enddo
- enddo
-
- end subroutine cmbgb24
-
-!***************************************************************************
- subroutine cmbgb25
-!***************************************************************************
-!
-! band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
-!-----------------------------------------------------------------------
-
- use rrsw_kg25, only : kao, sfluxrefo, &
- abso3ao, abso3bo, raylo, &
- absa, ka, sfluxref, &
- abso3a, abso3b, rayl
-
-! ------- Local -------
- integer(kind=im) :: jt, jp, igc, ipr, iprsm
- real(kind=rb) :: sumk, sumf1, sumf2, sumf3, sumf4
-
-
- do jt = 1,5
- do jp = 1,13
- iprsm = 0
- do igc = 1,ngc(10)
- sumk = 0.
- do ipr = 1, ngn(ngs(9)+igc)
- iprsm = iprsm + 1
- sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+144)
- enddo
- ka(jt,jp,igc) = sumk
- enddo
- enddo
- enddo
-
- iprsm = 0
- do igc = 1,ngc(10)
- sumf1 = 0.
- sumf2 = 0.
- sumf3 = 0.
- sumf4 = 0.
- do ipr = 1, ngn(ngs(9)+igc)
- iprsm = iprsm + 1
- sumf1 = sumf1 + sfluxrefo(iprsm)
- sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+144)
- sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+144)
- sumf4 = sumf4 + raylo(iprsm)*rwgt(iprsm+144)
- enddo
- sfluxref(igc) = sumf1
- abso3a(igc) = sumf2
- abso3b(igc) = sumf3
- rayl(igc) = sumf4
- enddo
-
- end subroutine cmbgb25
-
-!***************************************************************************
- subroutine cmbgb26
-!***************************************************************************
-!
-! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
-!-----------------------------------------------------------------------
-
- use rrsw_kg26, only : sfluxrefo, raylo, &
- sfluxref, rayl
-
-! ------- Local -------
- integer(kind=im) :: igc, ipr, iprsm
- real(kind=rb) :: sumf1, sumf2
-
-
- iprsm = 0
- do igc = 1,ngc(11)
- sumf1 = 0.
- sumf2 = 0.
- do ipr = 1, ngn(ngs(10)+igc)
- iprsm = iprsm + 1
- sumf1 = sumf1 + raylo(iprsm)*rwgt(iprsm+160)
- sumf2 = sumf2 + sfluxrefo(iprsm)
- enddo
- rayl(igc) = sumf1
- sfluxref(igc) = sumf2
- enddo
-
- end subroutine cmbgb26
-
-!***************************************************************************
- subroutine cmbgb27
-!***************************************************************************
-!
-! band 27: 29000-38000 cm-1 (low - o3; high - o3)
-!-----------------------------------------------------------------------
-
- use rrsw_kg27, only : kao, kbo, sfluxrefo, raylo, &
- absa, ka, absb, kb, sfluxref, rayl
-
-! ------- Local -------
- integer(kind=im) :: jt, jp, igc, ipr, iprsm
- real(kind=rb) :: sumk, sumf1, sumf2
-
-
- do jt = 1,5
- do jp = 1,13
- iprsm = 0
- do igc = 1,ngc(12)
- sumk = 0.
- do ipr = 1, ngn(ngs(11)+igc)
- iprsm = iprsm + 1
- sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+176)
- enddo
- ka(jt,jp,igc) = sumk
- enddo
- enddo
- do jp = 13,59
- iprsm = 0
- do igc = 1,ngc(12)
- sumk = 0.
- do ipr = 1, ngn(ngs(11)+igc)
- iprsm = iprsm + 1
- sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+176)
- enddo
- kb(jt,jp,igc) = sumk
- enddo
- enddo
- enddo
-
- iprsm = 0
- do igc = 1,ngc(12)
- sumf1 = 0.
- sumf2 = 0.
- do ipr = 1, ngn(ngs(11)+igc)
- iprsm = iprsm + 1
- sumf1 = sumf1 + sfluxrefo(iprsm)
- sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+176)
- enddo
- sfluxref(igc) = sumf1
- rayl(igc) = sumf2
- enddo
-
- end subroutine cmbgb27
-
-!***************************************************************************
- subroutine cmbgb28
-!***************************************************************************
-!
-! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2)
-!-----------------------------------------------------------------------
-
- use rrsw_kg28, only : kao, kbo, sfluxrefo, &
- absa, ka, absb, kb, sfluxref
-
-! ------- Local -------
- integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
- real(kind=rb) :: sumk, sumf
-
-
- do jn = 1,9
- do jt = 1,5
- do jp = 1,13
- iprsm = 0
- do igc = 1,ngc(13)
- sumk = 0.
- do ipr = 1, ngn(ngs(12)+igc)
- iprsm = iprsm + 1
- sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+192)
- enddo
- ka(jn,jt,jp,igc) = sumk
- enddo
- enddo
- enddo
- enddo
-
- do jn = 1,5
- do jt = 1,5
- do jp = 13,59
- iprsm = 0
- do igc = 1,ngc(13)
- sumk = 0.
- do ipr = 1, ngn(ngs(12)+igc)
- iprsm = iprsm + 1
- sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+192)
- enddo
- kb(jn,jt,jp,igc) = sumk
- enddo
- enddo
- enddo
- enddo
-
- do jp = 1,5
- iprsm = 0
- do igc = 1,ngc(13)
- sumf = 0.
- do ipr = 1, ngn(ngs(12)+igc)
- iprsm = iprsm + 1
- sumf = sumf + sfluxrefo(iprsm,jp)
- enddo
- sfluxref(igc,jp) = sumf
- enddo
- enddo
-
- end subroutine cmbgb28
-
-!***************************************************************************
- subroutine cmbgb29
-!***************************************************************************
-!
-! band 29: 820-2600 cm-1 (low - h2o; high - co2)
-!-----------------------------------------------------------------------
-
- use rrsw_kg29, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
- absh2oo, absco2o, &
- absa, ka, absb, kb, selfref, forref, sfluxref, &
- absh2o, absco2
-
-! ------- Local -------
- integer(kind=im) :: jt, jp, igc, ipr, iprsm
- real(kind=rb) :: sumk, sumf1, sumf2, sumf3
-
-
- do jt = 1,5
- do jp = 1,13
- iprsm = 0
- do igc = 1,ngc(14)
- sumk = 0.
- do ipr = 1, ngn(ngs(13)+igc)
- iprsm = iprsm + 1
- sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+208)
- enddo
- ka(jt,jp,igc) = sumk
- enddo
- enddo
- do jp = 13,59
- iprsm = 0
- do igc = 1,ngc(14)
- sumk = 0.
- do ipr = 1, ngn(ngs(13)+igc)
- iprsm = iprsm + 1
- sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+208)
- enddo
- kb(jt,jp,igc) = sumk
- enddo
- enddo
- enddo
-
- do jt = 1,10
- iprsm = 0
- do igc = 1,ngc(14)
- sumk = 0.
- do ipr = 1, ngn(ngs(13)+igc)
- iprsm = iprsm + 1
- sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+208)
- enddo
- selfref(jt,igc) = sumk
- enddo
- enddo
-
- do jt = 1,4
- iprsm = 0
- do igc = 1,ngc(14)
- sumk = 0.
- do ipr = 1, ngn(ngs(13)+igc)
- iprsm = iprsm + 1
- sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+208)
- enddo
- forref(jt,igc) = sumk
- enddo
- enddo
-
- iprsm = 0
- do igc = 1,ngc(14)
- sumf1 = 0.
- sumf2 = 0.
- sumf3 = 0.
- do ipr = 1, ngn(ngs(13)+igc)
- iprsm = iprsm + 1
- sumf1 = sumf1 + sfluxrefo(iprsm)
- sumf2 = sumf2 + absco2o(iprsm)*rwgt(iprsm+208)
- sumf3 = sumf3 + absh2oo(iprsm)*rwgt(iprsm+208)
- enddo
- sfluxref(igc) = sumf1
- absco2(igc) = sumf2
- absh2o(igc) = sumf3
- enddo
-
- end subroutine cmbgb29
-
-!***********************************************************************
- subroutine swcldpr
-
-! Purpose: Define cloud extinction coefficient, single scattering albedo
-! and asymmetry parameter data.
-!
-
-! ------- Modules -------
-
- use rrsw_cld, only : extliq1, ssaliq1, asyliq1, &
- extice2, ssaice2, asyice2, &
- extice3, ssaice3, asyice3, fdlice3, &
- abari, bbari, cbari, dbari, ebari, fbari
-
- save
-
-!-----------------------------------------------------------------------
-!
-! Explanation of the method for each value of INFLAG. A value of
-! 0 for INFLAG do not distingish being liquid and ice clouds.
-! INFLAG = 2 does distinguish between liquid and ice clouds, and
-! requires further user input to specify the method to be used to
-! compute the aborption due to each.
-! INFLAG = 0: For each cloudy layer, the cloud fraction, the cloud optical
-! depth, the cloud single-scattering albedo, and the
-! moments of the phase function (0:NSTREAM). Note
-! that these values are delta-m scaled within this
-! subroutine.
-
-! INFLAG = 2: For each cloudy layer, the cloud fraction, cloud
-! water path (g/m2), and cloud ice fraction are input.
-! ICEFLAG = 2: The ice effective radius (microns) is input and the
-! optical properties due to ice clouds are computed from
-! the optical properties stored in the RT code, STREAMER v3.0
-! (Reference: Key. J., Streamer User's Guide, Cooperative
-! Institute for Meteorological Satellite Studies, 2001, 96 pp.).
-! Valid range of values for re are between 5.0 and
-! 131.0 micron.
-! This version uses Ebert and Curry, JGR, (1992) method for
-! ice particles larger than 131.0 microns.
-! ICEFLAG = 3: The ice generalized effective size (dge) is input
-! and the optical depths, single-scattering albedo,
-! and phase function moments are calculated as in
-! Q. Fu, J. Climate, (1996). Q. Fu provided high resolution
-! tables which were appropriately averaged for the
-! bands in RRTM_SW. Linear interpolation is used to
-! get the coefficients from the stored tables.
-! Valid range of values for dge are between 5.0 and
-! 140.0 micron.
-! This version uses Ebert and Curry, JGR, (1992) method for
-! ice particles larger than 140.0 microns.
-! LIQFLAG = 1: The water droplet effective radius (microns) is input
-! and the optical depths due to water clouds are computed
-! as in Hu and Stamnes, J., Clim., 6, 728-742, (1993) with
-! modified coefficients derived from Mie scattering calculations.
-! The values for absorption coefficients appropriate for
-! the spectral bands in RRTM/RRTMG have been obtained for a
-! range of effective radii by an averaging procedure
-! based on the work of J. Pinto (private communication).
-! Linear interpolation is used to get the absorption
-! coefficients for the input effective radius.
-!
-!..Updated tables suggested by Peter Blossey (Univ. Washington) that came from RRTM v3.9 from AER, Inc.
-!
-! ------------------------------------------------------------------
-
-! Everything below is for INFLAG = 2.
-
-! Coefficients for Ebert and Curry method
- abari(:) = (/ &
- & 3.448e-03_rb,3.448e-03_rb,3.448e-03_rb,3.448e-03_rb,3.448e-03_rb /)
- bbari(:) = (/ &
- & 2.431e+00_rb,2.431e+00_rb,2.431e+00_rb,2.431e+00_rb,2.431e+00_rb /)
- cbari(:) = (/ &
- & 1.000e-05_rb,1.100e-04_rb,1.240e-02_rb,3.779e-02_rb,4.666e-01_rb /)
- dbari(:) = (/ &
- & 0.000e+00_rb,1.405e-05_rb,6.867e-04_rb,1.284e-03_rb,2.050e-05_rb /)
- ebari(:) = (/ &
- & 7.661e-01_rb,7.730e-01_rb,7.865e-01_rb,8.172e-01_rb,9.595e-01_rb /)
- fbari(:) = (/ &
- & 5.851e-04_rb,5.665e-04_rb,7.204e-04_rb,7.463e-04_rb,1.076e-04_rb /)
-
-! LIQFLAG==1 extinction coefficients, single scattering albedos, and asymmetry parameters
-! Derived from on Mie scattering computations; based on Hu & Stamnes coefficients
-! BAND 16
- extliq1(:, 16) = (/ &
- & 9.004493E-01_rb,6.366723E-01_rb,4.542354E-01_rb,3.468253E-01_rb,2.816431E-01_rb,&
- & 2.383415E-01_rb,2.070854E-01_rb,1.831854E-01_rb,1.642115E-01_rb,1.487539E-01_rb,&
- & 1.359169E-01_rb,1.250900E-01_rb,1.158354E-01_rb,1.078400E-01_rb,1.008646E-01_rb,&
- & 9.472307E-02_rb,8.928000E-02_rb,8.442308E-02_rb,8.005924E-02_rb,7.612231E-02_rb,&
- & 7.255153E-02_rb,6.929539E-02_rb,6.631769E-02_rb,6.358153E-02_rb,6.106231E-02_rb,&
- & 5.873077E-02_rb,5.656924E-02_rb,5.455769E-02_rb,5.267846E-02_rb,5.091923E-02_rb,&
- & 4.926692E-02_rb,4.771154E-02_rb,4.623923E-02_rb,4.484385E-02_rb,4.351539E-02_rb,&
- & 4.224615E-02_rb,4.103385E-02_rb,3.986538E-02_rb,3.874077E-02_rb,3.765462E-02_rb,&
- & 3.660077E-02_rb,3.557384E-02_rb,3.457615E-02_rb,3.360308E-02_rb,3.265000E-02_rb,&
- & 3.171770E-02_rb,3.080538E-02_rb,2.990846E-02_rb,2.903000E-02_rb,2.816461E-02_rb,&
- & 2.731539E-02_rb,2.648231E-02_rb,2.566308E-02_rb,2.485923E-02_rb,2.407000E-02_rb,&
- & 2.329615E-02_rb,2.253769E-02_rb,2.179615E-02_rb /)
-! BAND 17
- extliq1(:, 17) = (/ &
- & 6.741200e-01_rb,5.390739e-01_rb,4.198767e-01_rb,3.332553e-01_rb,2.735633e-01_rb,&
- & 2.317727e-01_rb,2.012760e-01_rb,1.780400e-01_rb,1.596927e-01_rb,1.447980e-01_rb,&
- & 1.324480e-01_rb,1.220347e-01_rb,1.131327e-01_rb,1.054313e-01_rb,9.870534e-02_rb,&
- & 9.278200e-02_rb,8.752599e-02_rb,8.282933e-02_rb,7.860600e-02_rb,7.479133e-02_rb,&
- & 7.132800e-02_rb,6.816733e-02_rb,6.527401e-02_rb,6.261266e-02_rb,6.015934e-02_rb,&
- & 5.788867e-02_rb,5.578134e-02_rb,5.381667e-02_rb,5.198133e-02_rb,5.026067e-02_rb,&
- & 4.864466e-02_rb,4.712267e-02_rb,4.568066e-02_rb,4.431200e-02_rb,4.300867e-02_rb,&
- & 4.176600e-02_rb,4.057400e-02_rb,3.942534e-02_rb,3.832066e-02_rb,3.725068e-02_rb,&
- & 3.621400e-02_rb,3.520533e-02_rb,3.422333e-02_rb,3.326400e-02_rb,3.232467e-02_rb,&
- & 3.140535e-02_rb,3.050400e-02_rb,2.962000e-02_rb,2.875267e-02_rb,2.789800e-02_rb,&
- & 2.705934e-02_rb,2.623667e-02_rb,2.542667e-02_rb,2.463200e-02_rb,2.385267e-02_rb,&
- & 2.308667e-02_rb,2.233667e-02_rb,2.160067e-02_rb /)
-! BAND 18
- extliq1(:, 18) = (/ &
- & 9.250861e-01_rb,6.245692e-01_rb,4.347038e-01_rb,3.320208e-01_rb,2.714869e-01_rb,&
- & 2.309516e-01_rb,2.012592e-01_rb,1.783315e-01_rb,1.600369e-01_rb,1.451000e-01_rb,&
- & 1.326838e-01_rb,1.222069e-01_rb,1.132554e-01_rb,1.055146e-01_rb,9.876000e-02_rb,&
- & 9.281386e-02_rb,8.754000e-02_rb,8.283078e-02_rb,7.860077e-02_rb,7.477769e-02_rb,&
- & 7.130847e-02_rb,6.814461e-02_rb,6.524615e-02_rb,6.258462e-02_rb,6.012847e-02_rb,&
- & 5.785462e-02_rb,5.574231e-02_rb,5.378000e-02_rb,5.194461e-02_rb,5.022462e-02_rb,&
- & 4.860846e-02_rb,4.708462e-02_rb,4.564154e-02_rb,4.427462e-02_rb,4.297231e-02_rb,&
- & 4.172769e-02_rb,4.053693e-02_rb,3.939000e-02_rb,3.828462e-02_rb,3.721692e-02_rb,&
- & 3.618000e-02_rb,3.517077e-02_rb,3.418923e-02_rb,3.323077e-02_rb,3.229154e-02_rb,&
- & 3.137154e-02_rb,3.047154e-02_rb,2.959077e-02_rb,2.872308e-02_rb,2.786846e-02_rb,&
- & 2.703077e-02_rb,2.620923e-02_rb,2.540077e-02_rb,2.460615e-02_rb,2.382693e-02_rb,&
- & 2.306231e-02_rb,2.231231e-02_rb,2.157923e-02_rb /)
-! BAND 19
- extliq1(:, 19) = (/ &
- & 9.298960e-01_rb,5.776460e-01_rb,4.083450e-01_rb,3.211160e-01_rb,2.666390e-01_rb,&
- & 2.281990e-01_rb,1.993250e-01_rb,1.768080e-01_rb,1.587810e-01_rb,1.440390e-01_rb,&
- & 1.317720e-01_rb,1.214150e-01_rb,1.125540e-01_rb,1.048890e-01_rb,9.819600e-02_rb,&
- & 9.230201e-02_rb,8.706900e-02_rb,8.239698e-02_rb,7.819500e-02_rb,7.439899e-02_rb,&
- & 7.095300e-02_rb,6.780700e-02_rb,6.492900e-02_rb,6.228600e-02_rb,5.984600e-02_rb,&
- & 5.758599e-02_rb,5.549099e-02_rb,5.353801e-02_rb,5.171400e-02_rb,5.000500e-02_rb,&
- & 4.840000e-02_rb,4.688500e-02_rb,4.545100e-02_rb,4.409300e-02_rb,4.279700e-02_rb,&
- & 4.156100e-02_rb,4.037700e-02_rb,3.923800e-02_rb,3.813800e-02_rb,3.707600e-02_rb,&
- & 3.604500e-02_rb,3.504300e-02_rb,3.406500e-02_rb,3.310800e-02_rb,3.217700e-02_rb,&
- & 3.126600e-02_rb,3.036800e-02_rb,2.948900e-02_rb,2.862400e-02_rb,2.777500e-02_rb,&
- & 2.694200e-02_rb,2.612300e-02_rb,2.531700e-02_rb,2.452800e-02_rb,2.375100e-02_rb,&
- & 2.299100e-02_rb,2.224300e-02_rb,2.151201e-02_rb /)
-! BAND 20
- extliq1(:, 20) = (/ &
- & 8.780964e-01_rb,5.407031e-01_rb,3.961100e-01_rb,3.166645e-01_rb,2.640455e-01_rb,&
- & 2.261070e-01_rb,1.974820e-01_rb,1.751775e-01_rb,1.573415e-01_rb,1.427725e-01_rb,&
- & 1.306535e-01_rb,1.204195e-01_rb,1.116650e-01_rb,1.040915e-01_rb,9.747550e-02_rb,&
- & 9.164800e-02_rb,8.647649e-02_rb,8.185501e-02_rb,7.770200e-02_rb,7.394749e-02_rb,&
- & 7.053800e-02_rb,6.742700e-02_rb,6.457999e-02_rb,6.196149e-02_rb,5.954450e-02_rb,&
- & 5.730650e-02_rb,5.522949e-02_rb,5.329450e-02_rb,5.148500e-02_rb,4.979000e-02_rb,&
- & 4.819600e-02_rb,4.669301e-02_rb,4.527050e-02_rb,4.391899e-02_rb,4.263500e-02_rb,&
- & 4.140500e-02_rb,4.022850e-02_rb,3.909500e-02_rb,3.800199e-02_rb,3.694600e-02_rb,&
- & 3.592000e-02_rb,3.492250e-02_rb,3.395050e-02_rb,3.300150e-02_rb,3.207250e-02_rb,&
- & 3.116250e-02_rb,3.027100e-02_rb,2.939500e-02_rb,2.853500e-02_rb,2.768900e-02_rb,&
- & 2.686000e-02_rb,2.604350e-02_rb,2.524150e-02_rb,2.445350e-02_rb,2.368049e-02_rb,&
- & 2.292150e-02_rb,2.217800e-02_rb,2.144800e-02_rb /)
-! BAND 21
- extliq1(:, 21) = (/ &
- & 7.937480e-01_rb,5.123036e-01_rb,3.858181e-01_rb,3.099622e-01_rb,2.586829e-01_rb,&
- & 2.217587e-01_rb,1.939755e-01_rb,1.723397e-01_rb,1.550258e-01_rb,1.408600e-01_rb,&
- & 1.290545e-01_rb,1.190661e-01_rb,1.105039e-01_rb,1.030848e-01_rb,9.659387e-02_rb,&
- & 9.086775e-02_rb,8.577807e-02_rb,8.122452e-02_rb,7.712711e-02_rb,7.342193e-02_rb,&
- & 7.005387e-02_rb,6.697840e-02_rb,6.416000e-02_rb,6.156903e-02_rb,5.917484e-02_rb,&
- & 5.695807e-02_rb,5.489968e-02_rb,5.298097e-02_rb,5.118806e-02_rb,4.950645e-02_rb,&
- & 4.792710e-02_rb,4.643581e-02_rb,4.502484e-02_rb,4.368547e-02_rb,4.241001e-02_rb,&
- & 4.118936e-02_rb,4.002193e-02_rb,3.889711e-02_rb,3.781322e-02_rb,3.676387e-02_rb,&
- & 3.574549e-02_rb,3.475548e-02_rb,3.379033e-02_rb,3.284678e-02_rb,3.192420e-02_rb,&
- & 3.102032e-02_rb,3.013484e-02_rb,2.926258e-02_rb,2.840839e-02_rb,2.756742e-02_rb,&
- & 2.674258e-02_rb,2.593064e-02_rb,2.513258e-02_rb,2.435000e-02_rb,2.358064e-02_rb,&
- & 2.282581e-02_rb,2.208548e-02_rb,2.135936e-02_rb /)
-! BAND 22
- extliq1(:, 22) = (/ &
- & 7.533129e-01_rb,5.033129e-01_rb,3.811271e-01_rb,3.062757e-01_rb,2.558729e-01_rb,&
- & 2.196828e-01_rb,1.924372e-01_rb,1.711714e-01_rb,1.541086e-01_rb,1.401114e-01_rb,&
- & 1.284257e-01_rb,1.185200e-01_rb,1.100243e-01_rb,1.026529e-01_rb,9.620142e-02_rb,&
- & 9.050714e-02_rb,8.544428e-02_rb,8.091714e-02_rb,7.684000e-02_rb,7.315429e-02_rb,&
- & 6.980143e-02_rb,6.673999e-02_rb,6.394000e-02_rb,6.136000e-02_rb,5.897715e-02_rb,&
- & 5.677000e-02_rb,5.472285e-02_rb,5.281286e-02_rb,5.102858e-02_rb,4.935429e-02_rb,&
- & 4.778000e-02_rb,4.629714e-02_rb,4.489142e-02_rb,4.355857e-02_rb,4.228715e-02_rb,&
- & 4.107285e-02_rb,3.990857e-02_rb,3.879000e-02_rb,3.770999e-02_rb,3.666429e-02_rb,&
- & 3.565000e-02_rb,3.466286e-02_rb,3.370143e-02_rb,3.276143e-02_rb,3.184143e-02_rb,&
- & 3.094000e-02_rb,3.005714e-02_rb,2.919000e-02_rb,2.833714e-02_rb,2.750000e-02_rb,&
- & 2.667714e-02_rb,2.586714e-02_rb,2.507143e-02_rb,2.429143e-02_rb,2.352428e-02_rb,&
- & 2.277143e-02_rb,2.203429e-02_rb,2.130857e-02_rb /)
-! BAND 23
- extliq1(:, 23) = (/ &
- & 7.079894e-01_rb,4.878198e-01_rb,3.719852e-01_rb,3.001873e-01_rb,2.514795e-01_rb,&
- & 2.163013e-01_rb,1.897100e-01_rb,1.689033e-01_rb,1.521793e-01_rb,1.384449e-01_rb,&
- & 1.269666e-01_rb,1.172326e-01_rb,1.088745e-01_rb,1.016224e-01_rb,9.527085e-02_rb,&
- & 8.966240e-02_rb,8.467543e-02_rb,8.021144e-02_rb,7.619344e-02_rb,7.255676e-02_rb,&
- & 6.924996e-02_rb,6.623030e-02_rb,6.346261e-02_rb,6.091499e-02_rb,5.856325e-02_rb,&
- & 5.638385e-02_rb,5.435930e-02_rb,5.247156e-02_rb,5.070699e-02_rb,4.905230e-02_rb,&
- & 4.749499e-02_rb,4.602611e-02_rb,4.463581e-02_rb,4.331543e-02_rb,4.205647e-02_rb,&
- & 4.085241e-02_rb,3.969978e-02_rb,3.859033e-02_rb,3.751877e-02_rb,3.648168e-02_rb,&
- & 3.547468e-02_rb,3.449553e-02_rb,3.354072e-02_rb,3.260732e-02_rb,3.169438e-02_rb,&
- & 3.079969e-02_rb,2.992146e-02_rb,2.905875e-02_rb,2.821201e-02_rb,2.737873e-02_rb,&
- & 2.656052e-02_rb,2.575586e-02_rb,2.496511e-02_rb,2.418783e-02_rb,2.342500e-02_rb,&
- & 2.267646e-02_rb,2.194177e-02_rb,2.122146e-02_rb /)
-! BAND 24
- extliq1(:, 24) = (/ &
- & 6.850164e-01_rb,4.762468e-01_rb,3.642001e-01_rb,2.946012e-01_rb,2.472001e-01_rb,&
- & 2.128588e-01_rb,1.868537e-01_rb,1.664893e-01_rb,1.501142e-01_rb,1.366620e-01_rb,&
- & 1.254147e-01_rb,1.158721e-01_rb,1.076732e-01_rb,1.005530e-01_rb,9.431306e-02_rb,&
- & 8.879891e-02_rb,8.389232e-02_rb,7.949714e-02_rb,7.553857e-02_rb,7.195474e-02_rb,&
- & 6.869413e-02_rb,6.571444e-02_rb,6.298286e-02_rb,6.046779e-02_rb,5.814474e-02_rb,&
- & 5.599141e-02_rb,5.399114e-02_rb,5.212443e-02_rb,5.037870e-02_rb,4.874321e-02_rb,&
- & 4.720219e-02_rb,4.574813e-02_rb,4.437160e-02_rb,4.306460e-02_rb,4.181810e-02_rb,&
- & 4.062603e-02_rb,3.948252e-02_rb,3.838256e-02_rb,3.732049e-02_rb,3.629192e-02_rb,&
- & 3.529301e-02_rb,3.432190e-02_rb,3.337412e-02_rb,3.244842e-02_rb,3.154175e-02_rb,&
- & 3.065253e-02_rb,2.978063e-02_rb,2.892367e-02_rb,2.808221e-02_rb,2.725478e-02_rb,&
- & 2.644174e-02_rb,2.564175e-02_rb,2.485508e-02_rb,2.408303e-02_rb,2.332365e-02_rb,&
- & 2.257890e-02_rb,2.184824e-02_rb,2.113224e-02_rb /)
-! BAND 25
- extliq1(:, 25) = (/ &
- & 6.673017e-01_rb,4.664520e-01_rb,3.579398e-01_rb,2.902234e-01_rb,2.439904e-01_rb,&
- & 2.104149e-01_rb,1.849277e-01_rb,1.649234e-01_rb,1.488087e-01_rb,1.355515e-01_rb,&
- & 1.244562e-01_rb,1.150329e-01_rb,1.069321e-01_rb,9.989310e-02_rb,9.372070e-02_rb,&
- & 8.826450e-02_rb,8.340622e-02_rb,7.905378e-02_rb,7.513109e-02_rb,7.157859e-02_rb,&
- & 6.834588e-02_rb,6.539114e-02_rb,6.268150e-02_rb,6.018621e-02_rb,5.788098e-02_rb,&
- & 5.574351e-02_rb,5.375699e-02_rb,5.190412e-02_rb,5.017099e-02_rb,4.854497e-02_rb,&
- & 4.701490e-02_rb,4.557030e-02_rb,4.420249e-02_rb,4.290304e-02_rb,4.166427e-02_rb,&
- & 4.047820e-02_rb,3.934232e-02_rb,3.824778e-02_rb,3.719236e-02_rb,3.616931e-02_rb,&
- & 3.517597e-02_rb,3.420856e-02_rb,3.326566e-02_rb,3.234346e-02_rb,3.144122e-02_rb,&
- & 3.055684e-02_rb,2.968798e-02_rb,2.883519e-02_rb,2.799635e-02_rb,2.717228e-02_rb,&
- & 2.636182e-02_rb,2.556424e-02_rb,2.478114e-02_rb,2.401086e-02_rb,2.325657e-02_rb,&
- & 2.251506e-02_rb,2.178594e-02_rb,2.107301e-02_rb /)
-! BAND 26
- extliq1(:, 26) = (/ &
- & 6.552414e-01_rb,4.599454e-01_rb,3.538626e-01_rb,2.873547e-01_rb,2.418033e-01_rb,&
- & 2.086660e-01_rb,1.834885e-01_rb,1.637142e-01_rb,1.477767e-01_rb,1.346583e-01_rb,&
- & 1.236734e-01_rb,1.143412e-01_rb,1.063148e-01_rb,9.933905e-02_rb,9.322026e-02_rb,&
- & 8.780979e-02_rb,8.299230e-02_rb,7.867554e-02_rb,7.478450e-02_rb,7.126053e-02_rb,&
- & 6.805276e-02_rb,6.512143e-02_rb,6.243211e-02_rb,5.995541e-02_rb,5.766712e-02_rb,&
- & 5.554484e-02_rb,5.357246e-02_rb,5.173222e-02_rb,5.001069e-02_rb,4.839505e-02_rb,&
- & 4.687471e-02_rb,4.543861e-02_rb,4.407857e-02_rb,4.278577e-02_rb,4.155331e-02_rb,&
- & 4.037322e-02_rb,3.924302e-02_rb,3.815376e-02_rb,3.710172e-02_rb,3.608296e-02_rb,&
- & 3.509330e-02_rb,3.412980e-02_rb,3.319009e-02_rb,3.227106e-02_rb,3.137157e-02_rb,&
- & 3.048950e-02_rb,2.962365e-02_rb,2.877297e-02_rb,2.793726e-02_rb,2.711500e-02_rb,&
- & 2.630666e-02_rb,2.551206e-02_rb,2.473052e-02_rb,2.396287e-02_rb,2.320861e-02_rb,&
- & 2.246810e-02_rb,2.174162e-02_rb,2.102927e-02_rb /)
-! BAND 27
- extliq1(:, 27) = (/ &
- & 6.430901e-01_rb,4.532134e-01_rb,3.496132e-01_rb,2.844655e-01_rb,2.397347e-01_rb,&
- & 2.071236e-01_rb,1.822976e-01_rb,1.627640e-01_rb,1.469961e-01_rb,1.340006e-01_rb,&
- & 1.231069e-01_rb,1.138441e-01_rb,1.058706e-01_rb,9.893678e-02_rb,9.285166e-02_rb,&
- & 8.746871e-02_rb,8.267411e-02_rb,7.837656e-02_rb,7.450257e-02_rb,7.099318e-02_rb,&
- & 6.779929e-02_rb,6.487987e-02_rb,6.220168e-02_rb,5.973530e-02_rb,5.745636e-02_rb,&
- & 5.534344e-02_rb,5.337986e-02_rb,5.154797e-02_rb,4.983404e-02_rb,4.822582e-02_rb,&
- & 4.671228e-02_rb,4.528321e-02_rb,4.392997e-02_rb,4.264325e-02_rb,4.141647e-02_rb,&
- & 4.024259e-02_rb,3.911767e-02_rb,3.803309e-02_rb,3.698782e-02_rb,3.597140e-02_rb,&
- & 3.498774e-02_rb,3.402852e-02_rb,3.309340e-02_rb,3.217818e-02_rb,3.128292e-02_rb,&
- & 3.040486e-02_rb,2.954230e-02_rb,2.869545e-02_rb,2.786261e-02_rb,2.704372e-02_rb,&
- & 2.623813e-02_rb,2.544668e-02_rb,2.466788e-02_rb,2.390313e-02_rb,2.315136e-02_rb,&
- & 2.241391e-02_rb,2.168921e-02_rb,2.097903e-02_rb /)
-! BAND 28
- extliq1(:, 28) = (/ &
- & 6.367074e-01_rb,4.495768e-01_rb,3.471263e-01_rb,2.826149e-01_rb,2.382868e-01_rb,&
- & 2.059640e-01_rb,1.813562e-01_rb,1.619881e-01_rb,1.463436e-01_rb,1.334402e-01_rb,&
- & 1.226166e-01_rb,1.134096e-01_rb,1.054829e-01_rb,9.858838e-02_rb,9.253790e-02_rb,&
- & 8.718582e-02_rb,8.241830e-02_rb,7.814482e-02_rb,7.429212e-02_rb,7.080165e-02_rb,&
- & 6.762385e-02_rb,6.471838e-02_rb,6.205388e-02_rb,5.959726e-02_rb,5.732871e-02_rb,&
- & 5.522402e-02_rb,5.326793e-02_rb,5.144230e-02_rb,4.973440e-02_rb,4.813188e-02_rb,&
- & 4.662283e-02_rb,4.519798e-02_rb,4.384833e-02_rb,4.256541e-02_rb,4.134253e-02_rb,&
- & 4.017136e-02_rb,3.904911e-02_rb,3.796779e-02_rb,3.692364e-02_rb,3.591182e-02_rb,&
- & 3.492930e-02_rb,3.397230e-02_rb,3.303920e-02_rb,3.212572e-02_rb,3.123278e-02_rb,&
- & 3.035519e-02_rb,2.949493e-02_rb,2.864985e-02_rb,2.781840e-02_rb,2.700197e-02_rb,&
- & 2.619682e-02_rb,2.540674e-02_rb,2.462966e-02_rb,2.386613e-02_rb,2.311602e-02_rb,&
- & 2.237846e-02_rb,2.165660e-02_rb,2.094756e-02_rb /)
-! BAND 29
- extliq1(:, 29) = (/ &
- & 4.298416e-01_rb,4.391639e-01_rb,3.975030e-01_rb,3.443028e-01_rb,2.957345e-01_rb,&
- & 2.556461e-01_rb,2.234755e-01_rb,1.976636e-01_rb,1.767428e-01_rb,1.595611e-01_rb,&
- & 1.452636e-01_rb,1.332156e-01_rb,1.229481e-01_rb,1.141059e-01_rb,1.064208e-01_rb,&
- & 9.968527e-02_rb,9.373833e-02_rb,8.845221e-02_rb,8.372112e-02_rb,7.946667e-02_rb,&
- & 7.561807e-02_rb,7.212029e-02_rb,6.893166e-02_rb,6.600944e-02_rb,6.332277e-02_rb,&
- & 6.084277e-02_rb,5.854721e-02_rb,5.641361e-02_rb,5.442639e-02_rb,5.256750e-02_rb,&
- & 5.082499e-02_rb,4.918556e-02_rb,4.763694e-02_rb,4.617222e-02_rb,4.477861e-02_rb,&
- & 4.344861e-02_rb,4.217999e-02_rb,4.096111e-02_rb,3.978638e-02_rb,3.865361e-02_rb,&
- & 3.755473e-02_rb,3.649028e-02_rb,3.545361e-02_rb,3.444361e-02_rb,3.345666e-02_rb,&
- & 3.249167e-02_rb,3.154722e-02_rb,3.062083e-02_rb,2.971250e-02_rb,2.882083e-02_rb,&
- & 2.794611e-02_rb,2.708778e-02_rb,2.624500e-02_rb,2.541750e-02_rb,2.460528e-02_rb,&
- & 2.381194e-02_rb,2.303250e-02_rb,2.226833e-02_rb /)
-! BAND 16
- ssaliq1(:, 16) = (/ &
- & 8.362119e-01_rb,8.098460e-01_rb,7.762291e-01_rb,7.486042e-01_rb,7.294172e-01_rb,&
- & 7.161000e-01_rb,7.060656e-01_rb,6.978387e-01_rb,6.907193e-01_rb,6.843551e-01_rb,&
- & 6.785668e-01_rb,6.732450e-01_rb,6.683191e-01_rb,6.637264e-01_rb,6.594307e-01_rb,&
- & 6.554033e-01_rb,6.516115e-01_rb,6.480295e-01_rb,6.446429e-01_rb,6.414306e-01_rb,&
- & 6.383783e-01_rb,6.354750e-01_rb,6.327068e-01_rb,6.300665e-01_rb,6.275376e-01_rb,&
- & 6.251245e-01_rb,6.228136e-01_rb,6.205944e-01_rb,6.184720e-01_rb,6.164330e-01_rb,&
- & 6.144742e-01_rb,6.125962e-01_rb,6.108004e-01_rb,6.090740e-01_rb,6.074200e-01_rb,&
- & 6.058381e-01_rb,6.043209e-01_rb,6.028681e-01_rb,6.014836e-01_rb,6.001626e-01_rb,&
- & 5.988957e-01_rb,5.976864e-01_rb,5.965390e-01_rb,5.954379e-01_rb,5.943972e-01_rb,&
- & 5.934019e-01_rb,5.924624e-01_rb,5.915579e-01_rb,5.907025e-01_rb,5.898913e-01_rb,&
- & 5.891213e-01_rb,5.883815e-01_rb,5.876851e-01_rb,5.870158e-01_rb,5.863868e-01_rb,&
- & 5.857821e-01_rb,5.852111e-01_rb,5.846579e-01_rb /)
-! BAND 17
- ssaliq1(:, 17) = (/ &
- & 6.995459e-01_rb,7.158012e-01_rb,7.076001e-01_rb,6.927244e-01_rb,6.786434e-01_rb,&
- & 6.673545e-01_rb,6.585859e-01_rb,6.516314e-01_rb,6.459010e-01_rb,6.410225e-01_rb,&
- & 6.367574e-01_rb,6.329554e-01_rb,6.295119e-01_rb,6.263595e-01_rb,6.234462e-01_rb,&
- & 6.207274e-01_rb,6.181755e-01_rb,6.157678e-01_rb,6.134880e-01_rb,6.113173e-01_rb,&
- & 6.092495e-01_rb,6.072689e-01_rb,6.053717e-01_rb,6.035507e-01_rb,6.018001e-01_rb,&
- & 6.001134e-01_rb,5.984951e-01_rb,5.969294e-01_rb,5.954256e-01_rb,5.939698e-01_rb,&
- & 5.925716e-01_rb,5.912265e-01_rb,5.899270e-01_rb,5.886771e-01_rb,5.874746e-01_rb,&
- & 5.863185e-01_rb,5.852077e-01_rb,5.841460e-01_rb,5.831249e-01_rb,5.821474e-01_rb,&
- & 5.812078e-01_rb,5.803173e-01_rb,5.794616e-01_rb,5.786443e-01_rb,5.778617e-01_rb,&
- & 5.771236e-01_rb,5.764191e-01_rb,5.757400e-01_rb,5.750971e-01_rb,5.744842e-01_rb,&
- & 5.739012e-01_rb,5.733482e-01_rb,5.728175e-01_rb,5.723214e-01_rb,5.718383e-01_rb,&
- & 5.713827e-01_rb,5.709471e-01_rb,5.705330e-01_rb /)
-! BAND 18
- ssaliq1(:, 18) = (/ &
- & 9.929711e-01_rb,9.896942e-01_rb,9.852408e-01_rb,9.806820e-01_rb,9.764512e-01_rb,&
- & 9.725375e-01_rb,9.688677e-01_rb,9.653832e-01_rb,9.620552e-01_rb,9.588522e-01_rb,&
- & 9.557475e-01_rb,9.527265e-01_rb,9.497731e-01_rb,9.468756e-01_rb,9.440270e-01_rb,&
- & 9.412230e-01_rb,9.384592e-01_rb,9.357287e-01_rb,9.330369e-01_rb,9.303778e-01_rb,&
- & 9.277502e-01_rb,9.251546e-01_rb,9.225907e-01_rb,9.200553e-01_rb,9.175521e-01_rb,&
- & 9.150773e-01_rb,9.126352e-01_rb,9.102260e-01_rb,9.078485e-01_rb,9.055057e-01_rb,&
- & 9.031978e-01_rb,9.009306e-01_rb,8.987010e-01_rb,8.965177e-01_rb,8.943774e-01_rb,&
- & 8.922869e-01_rb,8.902430e-01_rb,8.882551e-01_rb,8.863182e-01_rb,8.844373e-01_rb,&
- & 8.826143e-01_rb,8.808499e-01_rb,8.791413e-01_rb,8.774940e-01_rb,8.759019e-01_rb,&
- & 8.743650e-01_rb,8.728941e-01_rb,8.714712e-01_rb,8.701065e-01_rb,8.688008e-01_rb,&
- & 8.675409e-01_rb,8.663295e-01_rb,8.651714e-01_rb,8.640637e-01_rb,8.629943e-01_rb,&
- & 8.619762e-01_rb,8.609995e-01_rb,8.600581e-01_rb /)
-! BAND 19
- ssaliq1(:, 19) = (/ &
- & 9.910612e-01_rb,9.854226e-01_rb,9.795008e-01_rb,9.742920e-01_rb,9.695996e-01_rb,&
- & 9.652274e-01_rb,9.610648e-01_rb,9.570521e-01_rb,9.531397e-01_rb,9.493086e-01_rb,&
- & 9.455413e-01_rb,9.418362e-01_rb,9.381902e-01_rb,9.346016e-01_rb,9.310718e-01_rb,&
- & 9.275957e-01_rb,9.241757e-01_rb,9.208038e-01_rb,9.174802e-01_rb,9.142058e-01_rb,&
- & 9.109753e-01_rb,9.077895e-01_rb,9.046433e-01_rb,9.015409e-01_rb,8.984784e-01_rb,&
- & 8.954572e-01_rb,8.924748e-01_rb,8.895367e-01_rb,8.866395e-01_rb,8.837864e-01_rb,&
- & 8.809819e-01_rb,8.782267e-01_rb,8.755231e-01_rb,8.728712e-01_rb,8.702802e-01_rb,&
- & 8.677443e-01_rb,8.652733e-01_rb,8.628678e-01_rb,8.605300e-01_rb,8.582593e-01_rb,&
- & 8.560596e-01_rb,8.539352e-01_rb,8.518782e-01_rb,8.498915e-01_rb,8.479790e-01_rb,&
- & 8.461384e-01_rb,8.443645e-01_rb,8.426613e-01_rb,8.410229e-01_rb,8.394495e-01_rb,&
- & 8.379428e-01_rb,8.364967e-01_rb,8.351117e-01_rb,8.337820e-01_rb,8.325091e-01_rb,&
- & 8.312874e-01_rb,8.301169e-01_rb,8.289985e-01_rb /)
-! BAND 20
- ssaliq1(:, 20) = (/ &
- & 9.969802e-01_rb,9.950445e-01_rb,9.931448e-01_rb,9.914272e-01_rb,9.898652e-01_rb,&
- & 9.884250e-01_rb,9.870637e-01_rb,9.857482e-01_rb,9.844558e-01_rb,9.831755e-01_rb,&
- & 9.819068e-01_rb,9.806477e-01_rb,9.794000e-01_rb,9.781666e-01_rb,9.769461e-01_rb,&
- & 9.757386e-01_rb,9.745459e-01_rb,9.733650e-01_rb,9.721953e-01_rb,9.710398e-01_rb,&
- & 9.698936e-01_rb,9.687583e-01_rb,9.676334e-01_rb,9.665192e-01_rb,9.654132e-01_rb,&
- & 9.643208e-01_rb,9.632374e-01_rb,9.621625e-01_rb,9.611003e-01_rb,9.600518e-01_rb,&
- & 9.590144e-01_rb,9.579922e-01_rb,9.569864e-01_rb,9.559948e-01_rb,9.550239e-01_rb,&
- & 9.540698e-01_rb,9.531382e-01_rb,9.522280e-01_rb,9.513409e-01_rb,9.504772e-01_rb,&
- & 9.496360e-01_rb,9.488220e-01_rb,9.480327e-01_rb,9.472693e-01_rb,9.465333e-01_rb,&
- & 9.458211e-01_rb,9.451344e-01_rb,9.444732e-01_rb,9.438372e-01_rb,9.432268e-01_rb,&
- & 9.426391e-01_rb,9.420757e-01_rb,9.415308e-01_rb,9.410102e-01_rb,9.405115e-01_rb,&
- & 9.400326e-01_rb,9.395716e-01_rb,9.391313e-01_rb /)
-! BAND 21
- ssaliq1(:, 21) = (/ &
- & 9.980034e-01_rb,9.968572e-01_rb,9.958696e-01_rb,9.949747e-01_rb,9.941241e-01_rb,&
- & 9.933043e-01_rb,9.924971e-01_rb,9.916978e-01_rb,9.909023e-01_rb,9.901046e-01_rb,&
- & 9.893087e-01_rb,9.885146e-01_rb,9.877195e-01_rb,9.869283e-01_rb,9.861379e-01_rb,&
- & 9.853523e-01_rb,9.845715e-01_rb,9.837945e-01_rb,9.830217e-01_rb,9.822567e-01_rb,&
- & 9.814935e-01_rb,9.807356e-01_rb,9.799815e-01_rb,9.792332e-01_rb,9.784845e-01_rb,&
- & 9.777424e-01_rb,9.770042e-01_rb,9.762695e-01_rb,9.755416e-01_rb,9.748152e-01_rb,&
- & 9.740974e-01_rb,9.733873e-01_rb,9.726813e-01_rb,9.719861e-01_rb,9.713010e-01_rb,&
- & 9.706262e-01_rb,9.699647e-01_rb,9.693144e-01_rb,9.686794e-01_rb,9.680596e-01_rb,&
- & 9.674540e-01_rb,9.668657e-01_rb,9.662926e-01_rb,9.657390e-01_rb,9.652019e-01_rb,&
- & 9.646820e-01_rb,9.641784e-01_rb,9.636945e-01_rb,9.632260e-01_rb,9.627743e-01_rb,&
- & 9.623418e-01_rb,9.619227e-01_rb,9.615194e-01_rb,9.611341e-01_rb,9.607629e-01_rb,&
- & 9.604057e-01_rb,9.600622e-01_rb,9.597322e-01_rb /)
-! BAND 22
- ssaliq1(:, 22) = (/ &
- & 9.988219e-01_rb,9.981767e-01_rb,9.976168e-01_rb,9.971066e-01_rb,9.966195e-01_rb,&
- & 9.961566e-01_rb,9.956995e-01_rb,9.952481e-01_rb,9.947982e-01_rb,9.943495e-01_rb,&
- & 9.938955e-01_rb,9.934368e-01_rb,9.929825e-01_rb,9.925239e-01_rb,9.920653e-01_rb,&
- & 9.916096e-01_rb,9.911552e-01_rb,9.907067e-01_rb,9.902594e-01_rb,9.898178e-01_rb,&
- & 9.893791e-01_rb,9.889453e-01_rb,9.885122e-01_rb,9.880837e-01_rb,9.876567e-01_rb,&
- & 9.872331e-01_rb,9.868121e-01_rb,9.863938e-01_rb,9.859790e-01_rb,9.855650e-01_rb,&
- & 9.851548e-01_rb,9.847491e-01_rb,9.843496e-01_rb,9.839521e-01_rb,9.835606e-01_rb,&
- & 9.831771e-01_rb,9.827975e-01_rb,9.824292e-01_rb,9.820653e-01_rb,9.817124e-01_rb,&
- & 9.813644e-01_rb,9.810291e-01_rb,9.807020e-01_rb,9.803864e-01_rb,9.800782e-01_rb,&
- & 9.797821e-01_rb,9.794958e-01_rb,9.792179e-01_rb,9.789509e-01_rb,9.786940e-01_rb,&
- & 9.784460e-01_rb,9.782090e-01_rb,9.779789e-01_rb,9.777553e-01_rb,9.775425e-01_rb,&
- & 9.773387e-01_rb,9.771420e-01_rb,9.769529e-01_rb /)
-! BAND 23
- ssaliq1(:, 23) = (/ &
- & 9.998902e-01_rb,9.998395e-01_rb,9.997915e-01_rb,9.997442e-01_rb,9.997016e-01_rb,&
- & 9.996600e-01_rb,9.996200e-01_rb,9.995806e-01_rb,9.995411e-01_rb,9.995005e-01_rb,&
- & 9.994589e-01_rb,9.994178e-01_rb,9.993766e-01_rb,9.993359e-01_rb,9.992948e-01_rb,&
- & 9.992533e-01_rb,9.992120e-01_rb,9.991723e-01_rb,9.991313e-01_rb,9.990906e-01_rb,&
- & 9.990510e-01_rb,9.990113e-01_rb,9.989716e-01_rb,9.989323e-01_rb,9.988923e-01_rb,&
- & 9.988532e-01_rb,9.988140e-01_rb,9.987761e-01_rb,9.987373e-01_rb,9.986989e-01_rb,&
- & 9.986597e-01_rb,9.986239e-01_rb,9.985861e-01_rb,9.985485e-01_rb,9.985123e-01_rb,&
- & 9.984762e-01_rb,9.984415e-01_rb,9.984065e-01_rb,9.983722e-01_rb,9.983398e-01_rb,&
- & 9.983078e-01_rb,9.982758e-01_rb,9.982461e-01_rb,9.982157e-01_rb,9.981872e-01_rb,&
- & 9.981595e-01_rb,9.981324e-01_rb,9.981068e-01_rb,9.980811e-01_rb,9.980580e-01_rb,&
- & 9.980344e-01_rb,9.980111e-01_rb,9.979908e-01_rb,9.979690e-01_rb,9.979492e-01_rb,&
- & 9.979316e-01_rb,9.979116e-01_rb,9.978948e-01_rb /)
-! BAND 24
- ssaliq1(:, 24) = (/ &
- & 9.999978e-01_rb,9.999948e-01_rb,9.999915e-01_rb,9.999905e-01_rb,9.999896e-01_rb,&
- & 9.999887e-01_rb,9.999888e-01_rb,9.999888e-01_rb,9.999870e-01_rb,9.999854e-01_rb,&
- & 9.999855e-01_rb,9.999856e-01_rb,9.999839e-01_rb,9.999834e-01_rb,9.999829e-01_rb,&
- & 9.999809e-01_rb,9.999816e-01_rb,9.999793e-01_rb,9.999782e-01_rb,9.999779e-01_rb,&
- & 9.999772e-01_rb,9.999764e-01_rb,9.999756e-01_rb,9.999744e-01_rb,9.999744e-01_rb,&
- & 9.999736e-01_rb,9.999729e-01_rb,9.999716e-01_rb,9.999706e-01_rb,9.999692e-01_rb,&
- & 9.999690e-01_rb,9.999675e-01_rb,9.999673e-01_rb,9.999660e-01_rb,9.999654e-01_rb,&
- & 9.999647e-01_rb,9.999647e-01_rb,9.999625e-01_rb,9.999620e-01_rb,9.999614e-01_rb,&
- & 9.999613e-01_rb,9.999607e-01_rb,9.999604e-01_rb,9.999594e-01_rb,9.999589e-01_rb,&
- & 9.999586e-01_rb,9.999567e-01_rb,9.999550e-01_rb,9.999557e-01_rb,9.999542e-01_rb,&
- & 9.999546e-01_rb,9.999539e-01_rb,9.999536e-01_rb,9.999526e-01_rb,9.999523e-01_rb,&
- & 9.999508e-01_rb,9.999534e-01_rb,9.999507e-01_rb /)
-! BAND 25
- ssaliq1(:, 25) = (/ &
- & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,&
- & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,&
- & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,&
- & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,9.999995e-01_rb,&
- & 9.999995e-01_rb,9.999990e-01_rb,9.999991e-01_rb,9.999991e-01_rb,9.999990e-01_rb,&
- & 9.999989e-01_rb,9.999988e-01_rb,9.999988e-01_rb,9.999986e-01_rb,9.999988e-01_rb,&
- & 9.999986e-01_rb,9.999987e-01_rb,9.999986e-01_rb,9.999985e-01_rb,9.999985e-01_rb,&
- & 9.999985e-01_rb,9.999985e-01_rb,9.999983e-01_rb,9.999983e-01_rb,9.999981e-01_rb,&
- & 9.999981e-01_rb,9.999986e-01_rb,9.999985e-01_rb,9.999983e-01_rb,9.999984e-01_rb,&
- & 9.999982e-01_rb,9.999983e-01_rb,9.999982e-01_rb,9.999980e-01_rb,9.999981e-01_rb,&
- & 9.999978e-01_rb,9.999979e-01_rb,9.999985e-01_rb,9.999985e-01_rb,9.999983e-01_rb,&
- & 9.999983e-01_rb,9.999983e-01_rb,9.999983e-01_rb /)
-! BAND 26
- ssaliq1(:, 26) = (/ &
- & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,&
- & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,&
- & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,&
- & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,9.999991e-01_rb,&
- & 9.999990e-01_rb,9.999992e-01_rb,9.999995e-01_rb,9.999986e-01_rb,9.999994e-01_rb,&
- & 9.999985e-01_rb,9.999980e-01_rb,9.999984e-01_rb,9.999983e-01_rb,9.999979e-01_rb,&
- & 9.999969e-01_rb,9.999977e-01_rb,9.999971e-01_rb,9.999969e-01_rb,9.999969e-01_rb,&
- & 9.999965e-01_rb,9.999970e-01_rb,9.999985e-01_rb,9.999973e-01_rb,9.999961e-01_rb,&
- & 9.999968e-01_rb,9.999952e-01_rb,9.999970e-01_rb,9.999974e-01_rb,9.999965e-01_rb,&
- & 9.999969e-01_rb,9.999970e-01_rb,9.999970e-01_rb,9.999960e-01_rb,9.999923e-01_rb,&
- & 9.999958e-01_rb,9.999937e-01_rb,9.999960e-01_rb,9.999953e-01_rb,9.999946e-01_rb,&
- & 9.999946e-01_rb,9.999957e-01_rb,9.999951e-01_rb /)
-! BAND 27
- ssaliq1(:, 27) = (/ &
- & 1.000000e+00_rb,1.000000e+00_rb,9.999983e-01_rb,9.999979e-01_rb,9.999965e-01_rb,&
- & 9.999949e-01_rb,9.999948e-01_rb,9.999918e-01_rb,9.999917e-01_rb,9.999923e-01_rb,&
- & 9.999908e-01_rb,9.999889e-01_rb,9.999902e-01_rb,9.999895e-01_rb,9.999881e-01_rb,&
- & 9.999882e-01_rb,9.999876e-01_rb,9.999866e-01_rb,9.999866e-01_rb,9.999858e-01_rb,&
- & 9.999860e-01_rb,9.999852e-01_rb,9.999836e-01_rb,9.999831e-01_rb,9.999818e-01_rb,&
- & 9.999808e-01_rb,9.999816e-01_rb,9.999800e-01_rb,9.999783e-01_rb,9.999780e-01_rb,&
- & 9.999763e-01_rb,9.999746e-01_rb,9.999731e-01_rb,9.999713e-01_rb,9.999762e-01_rb,&
- & 9.999740e-01_rb,9.999670e-01_rb,9.999703e-01_rb,9.999687e-01_rb,9.999666e-01_rb,&
- & 9.999683e-01_rb,9.999667e-01_rb,9.999611e-01_rb,9.999635e-01_rb,9.999600e-01_rb,&
- & 9.999635e-01_rb,9.999594e-01_rb,9.999601e-01_rb,9.999586e-01_rb,9.999559e-01_rb,&
- & 9.999569e-01_rb,9.999558e-01_rb,9.999523e-01_rb,9.999535e-01_rb,9.999529e-01_rb,&
- & 9.999553e-01_rb,9.999495e-01_rb,9.999490e-01_rb /)
-! BAND 28
- ssaliq1(:, 28) = (/ &
- & 9.999920e-01_rb,9.999873e-01_rb,9.999855e-01_rb,9.999832e-01_rb,9.999807e-01_rb,&
- & 9.999778e-01_rb,9.999754e-01_rb,9.999721e-01_rb,9.999692e-01_rb,9.999651e-01_rb,&
- & 9.999621e-01_rb,9.999607e-01_rb,9.999567e-01_rb,9.999546e-01_rb,9.999521e-01_rb,&
- & 9.999491e-01_rb,9.999457e-01_rb,9.999439e-01_rb,9.999403e-01_rb,9.999374e-01_rb,&
- & 9.999353e-01_rb,9.999315e-01_rb,9.999282e-01_rb,9.999244e-01_rb,9.999234e-01_rb,&
- & 9.999189e-01_rb,9.999130e-01_rb,9.999117e-01_rb,9.999073e-01_rb,9.999020e-01_rb,&
- & 9.998993e-01_rb,9.998987e-01_rb,9.998922e-01_rb,9.998893e-01_rb,9.998869e-01_rb,&
- & 9.998805e-01_rb,9.998778e-01_rb,9.998751e-01_rb,9.998708e-01_rb,9.998676e-01_rb,&
- & 9.998624e-01_rb,9.998642e-01_rb,9.998582e-01_rb,9.998547e-01_rb,9.998546e-01_rb,&
- & 9.998477e-01_rb,9.998487e-01_rb,9.998466e-01_rb,9.998403e-01_rb,9.998412e-01_rb,&
- & 9.998406e-01_rb,9.998342e-01_rb,9.998326e-01_rb,9.998333e-01_rb,9.998328e-01_rb,&
- & 9.998290e-01_rb,9.998276e-01_rb,9.998249e-01_rb /)
-! BAND 29
- ssaliq1(:, 29) = (/ &
- & 8.383753e-01_rb,8.461471e-01_rb,8.373325e-01_rb,8.212889e-01_rb,8.023834e-01_rb,&
- & 7.829501e-01_rb,7.641777e-01_rb,7.466000e-01_rb,7.304023e-01_rb,7.155998e-01_rb,&
- & 7.021259e-01_rb,6.898840e-01_rb,6.787615e-01_rb,6.686479e-01_rb,6.594414e-01_rb,&
- & 6.510417e-01_rb,6.433668e-01_rb,6.363335e-01_rb,6.298788e-01_rb,6.239398e-01_rb,&
- & 6.184633e-01_rb,6.134055e-01_rb,6.087228e-01_rb,6.043786e-01_rb,6.003439e-01_rb,&
- & 5.965910e-01_rb,5.930917e-01_rb,5.898280e-01_rb,5.867798e-01_rb,5.839264e-01_rb,&
- & 5.812576e-01_rb,5.787592e-01_rb,5.764163e-01_rb,5.742189e-01_rb,5.721598e-01_rb,&
- & 5.702286e-01_rb,5.684182e-01_rb,5.667176e-01_rb,5.651237e-01_rb,5.636253e-01_rb,&
- & 5.622228e-01_rb,5.609074e-01_rb,5.596713e-01_rb,5.585089e-01_rb,5.574223e-01_rb,&
- & 5.564002e-01_rb,5.554411e-01_rb,5.545397e-01_rb,5.536914e-01_rb,5.528967e-01_rb,&
- & 5.521495e-01_rb,5.514457e-01_rb,5.507818e-01_rb,5.501623e-01_rb,5.495750e-01_rb,&
- & 5.490192e-01_rb,5.484980e-01_rb,5.480046e-01_rb /)
-! BAND 16
- asyliq1(:, 16) = (/ &
- & 8.038165e-01_rb,8.014154e-01_rb,7.942381e-01_rb,7.970521e-01_rb,8.086621e-01_rb,&
- & 8.233392e-01_rb,8.374127e-01_rb,8.495742e-01_rb,8.596945e-01_rb,8.680497e-01_rb,&
- & 8.750005e-01_rb,8.808589e-01_rb,8.858749e-01_rb,8.902403e-01_rb,8.940939e-01_rb,&
- & 8.975379e-01_rb,9.006450e-01_rb,9.034741e-01_rb,9.060659e-01_rb,9.084561e-01_rb,&
- & 9.106675e-01_rb,9.127198e-01_rb,9.146332e-01_rb,9.164194e-01_rb,9.180970e-01_rb,&
- & 9.196658e-01_rb,9.211421e-01_rb,9.225352e-01_rb,9.238443e-01_rb,9.250841e-01_rb,&
- & 9.262541e-01_rb,9.273620e-01_rb,9.284081e-01_rb,9.294002e-01_rb,9.303395e-01_rb,&
- & 9.312285e-01_rb,9.320715e-01_rb,9.328716e-01_rb,9.336271e-01_rb,9.343427e-01_rb,&
- & 9.350219e-01_rb,9.356647e-01_rb,9.362728e-01_rb,9.368495e-01_rb,9.373956e-01_rb,&
- & 9.379113e-01_rb,9.383987e-01_rb,9.388608e-01_rb,9.392986e-01_rb,9.397132e-01_rb,&
- & 9.401063e-01_rb,9.404776e-01_rb,9.408299e-01_rb,9.411641e-01_rb,9.414800e-01_rb,&
- & 9.417787e-01_rb,9.420633e-01_rb,9.423364e-01_rb /)
-! BAND 17
- asyliq1(:, 17) = (/ &
- & 8.941000e-01_rb,9.054049e-01_rb,9.049510e-01_rb,9.027216e-01_rb,9.021636e-01_rb,&
- & 9.037878e-01_rb,9.069852e-01_rb,9.109817e-01_rb,9.152013e-01_rb,9.193040e-01_rb,&
- & 9.231177e-01_rb,9.265712e-01_rb,9.296606e-01_rb,9.324048e-01_rb,9.348419e-01_rb,&
- & 9.370131e-01_rb,9.389529e-01_rb,9.406954e-01_rb,9.422727e-01_rb,9.437088e-01_rb,&
- & 9.450221e-01_rb,9.462308e-01_rb,9.473488e-01_rb,9.483830e-01_rb,9.493492e-01_rb,&
- & 9.502541e-01_rb,9.510999e-01_rb,9.518971e-01_rb,9.526455e-01_rb,9.533554e-01_rb,&
- & 9.540249e-01_rb,9.546571e-01_rb,9.552551e-01_rb,9.558258e-01_rb,9.563603e-01_rb,&
- & 9.568713e-01_rb,9.573569e-01_rb,9.578141e-01_rb,9.582485e-01_rb,9.586604e-01_rb,&
- & 9.590525e-01_rb,9.594218e-01_rb,9.597710e-01_rb,9.601052e-01_rb,9.604181e-01_rb,&
- & 9.607159e-01_rb,9.609979e-01_rb,9.612655e-01_rb,9.615184e-01_rb,9.617564e-01_rb,&
- & 9.619860e-01_rb,9.622009e-01_rb,9.624031e-01_rb,9.625957e-01_rb,9.627792e-01_rb,&
- & 9.629530e-01_rb,9.631171e-01_rb,9.632746e-01_rb /)
-! BAND 18
- asyliq1(:, 18) = (/ &
- & 8.574638e-01_rb,8.351383e-01_rb,8.142977e-01_rb,8.083068e-01_rb,8.129284e-01_rb,&
- & 8.215827e-01_rb,8.307238e-01_rb,8.389963e-01_rb,8.460481e-01_rb,8.519273e-01_rb,&
- & 8.568153e-01_rb,8.609116e-01_rb,8.643892e-01_rb,8.673941e-01_rb,8.700248e-01_rb,&
- & 8.723707e-01_rb,8.744902e-01_rb,8.764240e-01_rb,8.782057e-01_rb,8.798593e-01_rb,&
- & 8.814063e-01_rb,8.828573e-01_rb,8.842261e-01_rb,8.855196e-01_rb,8.867497e-01_rb,&
- & 8.879164e-01_rb,8.890316e-01_rb,8.900941e-01_rb,8.911118e-01_rb,8.920832e-01_rb,&
- & 8.930156e-01_rb,8.939091e-01_rb,8.947663e-01_rb,8.955888e-01_rb,8.963786e-01_rb,&
- & 8.971350e-01_rb,8.978617e-01_rb,8.985590e-01_rb,8.992243e-01_rb,8.998631e-01_rb,&
- & 9.004753e-01_rb,9.010602e-01_rb,9.016192e-01_rb,9.021542e-01_rb,9.026644e-01_rb,&
- & 9.031535e-01_rb,9.036194e-01_rb,9.040656e-01_rb,9.044894e-01_rb,9.048933e-01_rb,&
- & 9.052789e-01_rb,9.056481e-01_rb,9.060004e-01_rb,9.063343e-01_rb,9.066544e-01_rb,&
- & 9.069604e-01_rb,9.072512e-01_rb,9.075290e-01_rb /)
-! BAND 19
- asyliq1(:, 19) = (/ &
- & 8.349569e-01_rb,8.034579e-01_rb,7.932136e-01_rb,8.010156e-01_rb,8.137083e-01_rb,&
- & 8.255339e-01_rb,8.351938e-01_rb,8.428286e-01_rb,8.488944e-01_rb,8.538187e-01_rb,&
- & 8.579255e-01_rb,8.614473e-01_rb,8.645338e-01_rb,8.672908e-01_rb,8.697947e-01_rb,&
- & 8.720843e-01_rb,8.742015e-01_rb,8.761718e-01_rb,8.780160e-01_rb,8.797479e-01_rb,&
- & 8.813810e-01_rb,8.829250e-01_rb,8.843907e-01_rb,8.857822e-01_rb,8.871059e-01_rb,&
- & 8.883724e-01_rb,8.895810e-01_rb,8.907384e-01_rb,8.918456e-01_rb,8.929083e-01_rb,&
- & 8.939284e-01_rb,8.949060e-01_rb,8.958463e-01_rb,8.967486e-01_rb,8.976129e-01_rb,&
- & 8.984463e-01_rb,8.992439e-01_rb,9.000094e-01_rb,9.007438e-01_rb,9.014496e-01_rb,&
- & 9.021235e-01_rb,9.027699e-01_rb,9.033859e-01_rb,9.039772e-01_rb,9.045419e-01_rb,&
- & 9.050819e-01_rb,9.055975e-01_rb,9.060907e-01_rb,9.065607e-01_rb,9.070093e-01_rb,&
- & 9.074389e-01_rb,9.078475e-01_rb,9.082388e-01_rb,9.086117e-01_rb,9.089678e-01_rb,&
- & 9.093081e-01_rb,9.096307e-01_rb,9.099410e-01_rb /)
-! BAND 20
- asyliq1(:, 20) = (/ &
- & 8.109692e-01_rb,7.846657e-01_rb,7.881928e-01_rb,8.009509e-01_rb,8.131208e-01_rb,&
- & 8.230400e-01_rb,8.309448e-01_rb,8.372920e-01_rb,8.424837e-01_rb,8.468166e-01_rb,&
- & 8.504947e-01_rb,8.536642e-01_rb,8.564256e-01_rb,8.588513e-01_rb,8.610011e-01_rb,&
- & 8.629122e-01_rb,8.646262e-01_rb,8.661720e-01_rb,8.675752e-01_rb,8.688582e-01_rb,&
- & 8.700379e-01_rb,8.711300e-01_rb,8.721485e-01_rb,8.731027e-01_rb,8.740010e-01_rb,&
- & 8.748499e-01_rb,8.756564e-01_rb,8.764239e-01_rb,8.771542e-01_rb,8.778523e-01_rb,&
- & 8.785211e-01_rb,8.791601e-01_rb,8.797725e-01_rb,8.803589e-01_rb,8.809173e-01_rb,&
- & 8.814552e-01_rb,8.819705e-01_rb,8.824611e-01_rb,8.829311e-01_rb,8.833791e-01_rb,&
- & 8.838078e-01_rb,8.842148e-01_rb,8.846044e-01_rb,8.849756e-01_rb,8.853291e-01_rb,&
- & 8.856645e-01_rb,8.859841e-01_rb,8.862904e-01_rb,8.865801e-01_rb,8.868551e-01_rb,&
- & 8.871182e-01_rb,8.873673e-01_rb,8.876059e-01_rb,8.878307e-01_rb,8.880462e-01_rb,&
- & 8.882501e-01_rb,8.884453e-01_rb,8.886339e-01_rb /)
-! BAND 21
- asyliq1(:, 21) = (/ &
- & 7.838510e-01_rb,7.803151e-01_rb,7.980477e-01_rb,8.144160e-01_rb,8.261784e-01_rb,&
- & 8.344240e-01_rb,8.404278e-01_rb,8.450391e-01_rb,8.487593e-01_rb,8.518741e-01_rb,&
- & 8.545484e-01_rb,8.568890e-01_rb,8.589560e-01_rb,8.607983e-01_rb,8.624504e-01_rb,&
- & 8.639408e-01_rb,8.652945e-01_rb,8.665301e-01_rb,8.676634e-01_rb,8.687121e-01_rb,&
- & 8.696855e-01_rb,8.705933e-01_rb,8.714448e-01_rb,8.722454e-01_rb,8.730014e-01_rb,&
- & 8.737180e-01_rb,8.743982e-01_rb,8.750436e-01_rb,8.756598e-01_rb,8.762481e-01_rb,&
- & 8.768089e-01_rb,8.773427e-01_rb,8.778532e-01_rb,8.783434e-01_rb,8.788089e-01_rb,&
- & 8.792530e-01_rb,8.796784e-01_rb,8.800845e-01_rb,8.804716e-01_rb,8.808411e-01_rb,&
- & 8.811923e-01_rb,8.815276e-01_rb,8.818472e-01_rb,8.821504e-01_rb,8.824408e-01_rb,&
- & 8.827155e-01_rb,8.829777e-01_rb,8.832269e-01_rb,8.834631e-01_rb,8.836892e-01_rb,&
- & 8.839034e-01_rb,8.841075e-01_rb,8.843021e-01_rb,8.844866e-01_rb,8.846631e-01_rb,&
- & 8.848304e-01_rb,8.849910e-01_rb,8.851425e-01_rb /)
-! BAND 22
- asyliq1(:, 22) = (/ &
- & 7.760783e-01_rb,7.890215e-01_rb,8.090192e-01_rb,8.230252e-01_rb,8.321369e-01_rb,&
- & 8.384258e-01_rb,8.431529e-01_rb,8.469558e-01_rb,8.501499e-01_rb,8.528899e-01_rb,&
- & 8.552899e-01_rb,8.573956e-01_rb,8.592570e-01_rb,8.609098e-01_rb,8.623897e-01_rb,&
- & 8.637169e-01_rb,8.649184e-01_rb,8.660097e-01_rb,8.670096e-01_rb,8.679338e-01_rb,&
- & 8.687896e-01_rb,8.695880e-01_rb,8.703365e-01_rb,8.710422e-01_rb,8.717092e-01_rb,&
- & 8.723378e-01_rb,8.729363e-01_rb,8.735063e-01_rb,8.740475e-01_rb,8.745661e-01_rb,&
- & 8.750560e-01_rb,8.755275e-01_rb,8.759731e-01_rb,8.764000e-01_rb,8.768071e-01_rb,&
- & 8.771942e-01_rb,8.775628e-01_rb,8.779126e-01_rb,8.782483e-01_rb,8.785626e-01_rb,&
- & 8.788610e-01_rb,8.791482e-01_rb,8.794180e-01_rb,8.796765e-01_rb,8.799207e-01_rb,&
- & 8.801522e-01_rb,8.803707e-01_rb,8.805777e-01_rb,8.807749e-01_rb,8.809605e-01_rb,&
- & 8.811362e-01_rb,8.813047e-01_rb,8.814647e-01_rb,8.816131e-01_rb,8.817588e-01_rb,&
- & 8.818930e-01_rb,8.820230e-01_rb,8.821445e-01_rb /)
-! BAND 23
- asyliq1(:, 23) = (/ &
- & 7.847907e-01_rb,8.099917e-01_rb,8.257428e-01_rb,8.350423e-01_rb,8.411971e-01_rb,&
- & 8.457241e-01_rb,8.493010e-01_rb,8.522565e-01_rb,8.547660e-01_rb,8.569311e-01_rb,&
- & 8.588181e-01_rb,8.604729e-01_rb,8.619296e-01_rb,8.632208e-01_rb,8.643725e-01_rb,&
- & 8.654050e-01_rb,8.663363e-01_rb,8.671835e-01_rb,8.679590e-01_rb,8.686707e-01_rb,&
- & 8.693308e-01_rb,8.699433e-01_rb,8.705147e-01_rb,8.710490e-01_rb,8.715497e-01_rb,&
- & 8.720219e-01_rb,8.724669e-01_rb,8.728849e-01_rb,8.732806e-01_rb,8.736550e-01_rb,&
- & 8.740099e-01_rb,8.743435e-01_rb,8.746601e-01_rb,8.749610e-01_rb,8.752449e-01_rb,&
- & 8.755143e-01_rb,8.757688e-01_rb,8.760095e-01_rb,8.762375e-01_rb,8.764532e-01_rb,&
- & 8.766579e-01_rb,8.768506e-01_rb,8.770323e-01_rb,8.772049e-01_rb,8.773690e-01_rb,&
- & 8.775226e-01_rb,8.776679e-01_rb,8.778062e-01_rb,8.779360e-01_rb,8.780587e-01_rb,&
- & 8.781747e-01_rb,8.782852e-01_rb,8.783892e-01_rb,8.784891e-01_rb,8.785824e-01_rb,&
- & 8.786705e-01_rb,8.787546e-01_rb,8.788336e-01_rb /)
-! BAND 24
- asyliq1(:, 24) = (/ &
- & 8.054324e-01_rb,8.266282e-01_rb,8.378075e-01_rb,8.449848e-01_rb,8.502166e-01_rb,&
- & 8.542268e-01_rb,8.573477e-01_rb,8.598022e-01_rb,8.617689e-01_rb,8.633859e-01_rb,&
- & 8.647536e-01_rb,8.659354e-01_rb,8.669807e-01_rb,8.679143e-01_rb,8.687577e-01_rb,&
- & 8.695222e-01_rb,8.702207e-01_rb,8.708591e-01_rb,8.714446e-01_rb,8.719836e-01_rb,&
- & 8.724812e-01_rb,8.729426e-01_rb,8.733689e-01_rb,8.737665e-01_rb,8.741373e-01_rb,&
- & 8.744834e-01_rb,8.748070e-01_rb,8.751131e-01_rb,8.754011e-01_rb,8.756676e-01_rb,&
- & 8.759219e-01_rb,8.761599e-01_rb,8.763857e-01_rb,8.765984e-01_rb,8.767999e-01_rb,&
- & 8.769889e-01_rb,8.771669e-01_rb,8.773373e-01_rb,8.774969e-01_rb,8.776469e-01_rb,&
- & 8.777894e-01_rb,8.779237e-01_rb,8.780505e-01_rb,8.781703e-01_rb,8.782820e-01_rb,&
- & 8.783886e-01_rb,8.784894e-01_rb,8.785844e-01_rb,8.786736e-01_rb,8.787584e-01_rb,&
- & 8.788379e-01_rb,8.789130e-01_rb,8.789849e-01_rb,8.790506e-01_rb,8.791141e-01_rb,&
- & 8.791750e-01_rb,8.792324e-01_rb,8.792867e-01_rb /)
-! BAND 25
- asyliq1(:, 25) = (/ &
- & 8.249534e-01_rb,8.391988e-01_rb,8.474107e-01_rb,8.526860e-01_rb,8.563983e-01_rb,&
- & 8.592389e-01_rb,8.615144e-01_rb,8.633790e-01_rb,8.649325e-01_rb,8.662504e-01_rb,&
- & 8.673841e-01_rb,8.683741e-01_rb,8.692495e-01_rb,8.700309e-01_rb,8.707328e-01_rb,&
- & 8.713650e-01_rb,8.719432e-01_rb,8.724676e-01_rb,8.729498e-01_rb,8.733922e-01_rb,&
- & 8.737981e-01_rb,8.741745e-01_rb,8.745225e-01_rb,8.748467e-01_rb,8.751512e-01_rb,&
- & 8.754315e-01_rb,8.756962e-01_rb,8.759450e-01_rb,8.761774e-01_rb,8.763945e-01_rb,&
- & 8.766021e-01_rb,8.767970e-01_rb,8.769803e-01_rb,8.771511e-01_rb,8.773151e-01_rb,&
- & 8.774689e-01_rb,8.776147e-01_rb,8.777533e-01_rb,8.778831e-01_rb,8.780050e-01_rb,&
- & 8.781197e-01_rb,8.782301e-01_rb,8.783323e-01_rb,8.784312e-01_rb,8.785222e-01_rb,&
- & 8.786096e-01_rb,8.786916e-01_rb,8.787688e-01_rb,8.788411e-01_rb,8.789122e-01_rb,&
- & 8.789762e-01_rb,8.790373e-01_rb,8.790954e-01_rb,8.791514e-01_rb,8.792018e-01_rb,&
- & 8.792517e-01_rb,8.792990e-01_rb,8.793429e-01_rb /)
-! BAND 26
- asyliq1(:, 26) = (/ &
- & 8.323091e-01_rb,8.429776e-01_rb,8.498123e-01_rb,8.546929e-01_rb,8.584295e-01_rb,&
- & 8.613489e-01_rb,8.636324e-01_rb,8.654303e-01_rb,8.668675e-01_rb,8.680404e-01_rb,&
- & 8.690174e-01_rb,8.698495e-01_rb,8.705666e-01_rb,8.711961e-01_rb,8.717556e-01_rb,&
- & 8.722546e-01_rb,8.727063e-01_rb,8.731170e-01_rb,8.734933e-01_rb,8.738382e-01_rb,&
- & 8.741590e-01_rb,8.744525e-01_rb,8.747295e-01_rb,8.749843e-01_rb,8.752210e-01_rb,&
- & 8.754437e-01_rb,8.756524e-01_rb,8.758472e-01_rb,8.760288e-01_rb,8.762030e-01_rb,&
- & 8.763603e-01_rb,8.765122e-01_rb,8.766539e-01_rb,8.767894e-01_rb,8.769130e-01_rb,&
- & 8.770310e-01_rb,8.771422e-01_rb,8.772437e-01_rb,8.773419e-01_rb,8.774355e-01_rb,&
- & 8.775221e-01_rb,8.776047e-01_rb,8.776802e-01_rb,8.777539e-01_rb,8.778216e-01_rb,&
- & 8.778859e-01_rb,8.779473e-01_rb,8.780031e-01_rb,8.780562e-01_rb,8.781097e-01_rb,&
- & 8.781570e-01_rb,8.782021e-01_rb,8.782463e-01_rb,8.782845e-01_rb,8.783235e-01_rb,&
- & 8.783610e-01_rb,8.783953e-01_rb,8.784273e-01_rb /)
-! BAND 27
- asyliq1(:, 27) = (/ &
- & 8.396448e-01_rb,8.480172e-01_rb,8.535934e-01_rb,8.574145e-01_rb,8.600835e-01_rb,&
- & 8.620347e-01_rb,8.635500e-01_rb,8.648003e-01_rb,8.658758e-01_rb,8.668248e-01_rb,&
- & 8.676697e-01_rb,8.684220e-01_rb,8.690893e-01_rb,8.696807e-01_rb,8.702046e-01_rb,&
- & 8.706676e-01_rb,8.710798e-01_rb,8.714478e-01_rb,8.717778e-01_rb,8.720747e-01_rb,&
- & 8.723431e-01_rb,8.725889e-01_rb,8.728144e-01_rb,8.730201e-01_rb,8.732129e-01_rb,&
- & 8.733907e-01_rb,8.735541e-01_rb,8.737100e-01_rb,8.738533e-01_rb,8.739882e-01_rb,&
- & 8.741164e-01_rb,8.742362e-01_rb,8.743485e-01_rb,8.744530e-01_rb,8.745512e-01_rb,&
- & 8.746471e-01_rb,8.747373e-01_rb,8.748186e-01_rb,8.748973e-01_rb,8.749732e-01_rb,&
- & 8.750443e-01_rb,8.751105e-01_rb,8.751747e-01_rb,8.752344e-01_rb,8.752902e-01_rb,&
- & 8.753412e-01_rb,8.753917e-01_rb,8.754393e-01_rb,8.754843e-01_rb,8.755282e-01_rb,&
- & 8.755662e-01_rb,8.756039e-01_rb,8.756408e-01_rb,8.756722e-01_rb,8.757072e-01_rb,&
- & 8.757352e-01_rb,8.757653e-01_rb,8.757932e-01_rb /)
-! BAND 28
- asyliq1(:, 28) = (/ &
- & 8.374590e-01_rb,8.465669e-01_rb,8.518701e-01_rb,8.547627e-01_rb,8.565745e-01_rb,&
- & 8.579065e-01_rb,8.589717e-01_rb,8.598632e-01_rb,8.606363e-01_rb,8.613268e-01_rb,&
- & 8.619560e-01_rb,8.625340e-01_rb,8.630689e-01_rb,8.635601e-01_rb,8.640084e-01_rb,&
- & 8.644180e-01_rb,8.647885e-01_rb,8.651220e-01_rb,8.654218e-01_rb,8.656908e-01_rb,&
- & 8.659294e-01_rb,8.661422e-01_rb,8.663334e-01_rb,8.665037e-01_rb,8.666543e-01_rb,&
- & 8.667913e-01_rb,8.669156e-01_rb,8.670242e-01_rb,8.671249e-01_rb,8.672161e-01_rb,&
- & 8.672993e-01_rb,8.673733e-01_rb,8.674457e-01_rb,8.675103e-01_rb,8.675713e-01_rb,&
- & 8.676267e-01_rb,8.676798e-01_rb,8.677286e-01_rb,8.677745e-01_rb,8.678178e-01_rb,&
- & 8.678601e-01_rb,8.678986e-01_rb,8.679351e-01_rb,8.679693e-01_rb,8.680013e-01_rb,&
- & 8.680334e-01_rb,8.680624e-01_rb,8.680915e-01_rb,8.681178e-01_rb,8.681428e-01_rb,&
- & 8.681654e-01_rb,8.681899e-01_rb,8.682103e-01_rb,8.682317e-01_rb,8.682498e-01_rb,&
- & 8.682677e-01_rb,8.682861e-01_rb,8.683041e-01_rb /)
-! BAND 29
- asyliq1(:, 29) = (/ &
- & 7.877069e-01_rb,8.244281e-01_rb,8.367971e-01_rb,8.409074e-01_rb,8.429859e-01_rb,&
- & 8.454386e-01_rb,8.489350e-01_rb,8.534141e-01_rb,8.585814e-01_rb,8.641267e-01_rb,&
- & 8.697999e-01_rb,8.754223e-01_rb,8.808785e-01_rb,8.860944e-01_rb,8.910354e-01_rb,&
- & 8.956837e-01_rb,9.000392e-01_rb,9.041091e-01_rb,9.079071e-01_rb,9.114479e-01_rb,&
- & 9.147462e-01_rb,9.178234e-01_rb,9.206903e-01_rb,9.233663e-01_rb,9.258668e-01_rb,&
- & 9.282006e-01_rb,9.303847e-01_rb,9.324288e-01_rb,9.343418e-01_rb,9.361356e-01_rb,&
- & 9.378176e-01_rb,9.393939e-01_rb,9.408736e-01_rb,9.422622e-01_rb,9.435670e-01_rb,&
- & 9.447900e-01_rb,9.459395e-01_rb,9.470199e-01_rb,9.480335e-01_rb,9.489852e-01_rb,&
- & 9.498782e-01_rb,9.507168e-01_rb,9.515044e-01_rb,9.522470e-01_rb,9.529409e-01_rb,&
- & 9.535946e-01_rb,9.542071e-01_rb,9.547838e-01_rb,9.553256e-01_rb,9.558351e-01_rb,&
- & 9.563139e-01_rb,9.567660e-01_rb,9.571915e-01_rb,9.575901e-01_rb,9.579685e-01_rb,&
- & 9.583239e-01_rb,9.586602e-01_rb,9.589766e-01_rb /)
-
-
-! Spherical Ice Particle Parameterization
-! extinction units (ext coef/iwc): [(m^-1)/(g m^-3)]
- extice2(:, 16) = (/ &
-! band 16
- & 4.101824e-01_rb,2.435514e-01_rb,1.713697e-01_rb,1.314865e-01_rb,1.063406e-01_rb,&
- & 8.910701e-02_rb,7.659480e-02_rb,6.711784e-02_rb,5.970353e-02_rb,5.375249e-02_rb,&
- & 4.887577e-02_rb,4.481025e-02_rb,4.137171e-02_rb,3.842744e-02_rb,3.587948e-02_rb,&
- & 3.365396e-02_rb,3.169419e-02_rb,2.995593e-02_rb,2.840419e-02_rb,2.701091e-02_rb,&
- & 2.575336e-02_rb,2.461293e-02_rb,2.357423e-02_rb,2.262443e-02_rb,2.175276e-02_rb,&
- & 2.095012e-02_rb,2.020875e-02_rb,1.952199e-02_rb,1.888412e-02_rb,1.829018e-02_rb,&
- & 1.773586e-02_rb,1.721738e-02_rb,1.673144e-02_rb,1.627510e-02_rb,1.584579e-02_rb,&
- & 1.544122e-02_rb,1.505934e-02_rb,1.469833e-02_rb,1.435654e-02_rb,1.403251e-02_rb,&
- & 1.372492e-02_rb,1.343255e-02_rb,1.315433e-02_rb /)
- extice2(:, 17) = (/ &
-! band 17
- & 3.836650e-01_rb,2.304055e-01_rb,1.637265e-01_rb,1.266681e-01_rb,1.031602e-01_rb,&
- & 8.695191e-02_rb,7.511544e-02_rb,6.610009e-02_rb,5.900909e-02_rb,5.328833e-02_rb,&
- & 4.857728e-02_rb,4.463133e-02_rb,4.127880e-02_rb,3.839567e-02_rb,3.589013e-02_rb,&
- & 3.369280e-02_rb,3.175027e-02_rb,3.002079e-02_rb,2.847121e-02_rb,2.707493e-02_rb,&
- & 2.581031e-02_rb,2.465962e-02_rb,2.360815e-02_rb,2.264363e-02_rb,2.175571e-02_rb,&
- & 2.093563e-02_rb,2.017592e-02_rb,1.947015e-02_rb,1.881278e-02_rb,1.819901e-02_rb,&
- & 1.762463e-02_rb,1.708598e-02_rb,1.657982e-02_rb,1.610330e-02_rb,1.565390e-02_rb,&
- & 1.522937e-02_rb,1.482768e-02_rb,1.444706e-02_rb,1.408588e-02_rb,1.374270e-02_rb,&
- & 1.341619e-02_rb,1.310517e-02_rb,1.280857e-02_rb /)
- extice2(:, 18) = (/ &
-! band 18
- & 4.152673e-01_rb,2.436816e-01_rb,1.702243e-01_rb,1.299704e-01_rb,1.047528e-01_rb,&
- & 8.756039e-02_rb,7.513327e-02_rb,6.575690e-02_rb,5.844616e-02_rb,5.259609e-02_rb,&
- & 4.781531e-02_rb,4.383980e-02_rb,4.048517e-02_rb,3.761891e-02_rb,3.514342e-02_rb,&
- & 3.298525e-02_rb,3.108814e-02_rb,2.940825e-02_rb,2.791096e-02_rb,2.656858e-02_rb,&
- & 2.535869e-02_rb,2.426297e-02_rb,2.326627e-02_rb,2.235602e-02_rb,2.152164e-02_rb,&
- & 2.075420e-02_rb,2.004613e-02_rb,1.939091e-02_rb,1.878296e-02_rb,1.821744e-02_rb,&
- & 1.769015e-02_rb,1.719741e-02_rb,1.673600e-02_rb,1.630308e-02_rb,1.589615e-02_rb,&
- & 1.551298e-02_rb,1.515159e-02_rb,1.481021e-02_rb,1.448726e-02_rb,1.418131e-02_rb,&
- & 1.389109e-02_rb,1.361544e-02_rb,1.335330e-02_rb /)
- extice2(:, 19) = (/ &
-! band 19
- & 3.873250e-01_rb,2.331609e-01_rb,1.655002e-01_rb,1.277753e-01_rb,1.038247e-01_rb,&
- & 8.731780e-02_rb,7.527638e-02_rb,6.611873e-02_rb,5.892850e-02_rb,5.313885e-02_rb,&
- & 4.838068e-02_rb,4.440356e-02_rb,4.103167e-02_rb,3.813804e-02_rb,3.562870e-02_rb,&
- & 3.343269e-02_rb,3.149539e-02_rb,2.977414e-02_rb,2.823510e-02_rb,2.685112e-02_rb,&
- & 2.560015e-02_rb,2.446411e-02_rb,2.342805e-02_rb,2.247948e-02_rb,2.160789e-02_rb,&
- & 2.080438e-02_rb,2.006139e-02_rb,1.937238e-02_rb,1.873177e-02_rb,1.813469e-02_rb,&
- & 1.757689e-02_rb,1.705468e-02_rb,1.656479e-02_rb,1.610435e-02_rb,1.567081e-02_rb,&
- & 1.526192e-02_rb,1.487565e-02_rb,1.451020e-02_rb,1.416396e-02_rb,1.383546e-02_rb,&
- & 1.352339e-02_rb,1.322657e-02_rb,1.294392e-02_rb /)
- extice2(:, 20) = (/ &
-! band 20
- & 3.784280e-01_rb,2.291396e-01_rb,1.632551e-01_rb,1.263775e-01_rb,1.028944e-01_rb,&
- & 8.666975e-02_rb,7.480952e-02_rb,6.577335e-02_rb,5.866714e-02_rb,5.293694e-02_rb,&
- & 4.822153e-02_rb,4.427547e-02_rb,4.092626e-02_rb,3.804918e-02_rb,3.555184e-02_rb,&
- & 3.336440e-02_rb,3.143307e-02_rb,2.971577e-02_rb,2.817912e-02_rb,2.679632e-02_rb,&
- & 2.554558e-02_rb,2.440903e-02_rb,2.337187e-02_rb,2.242173e-02_rb,2.154821e-02_rb,&
- & 2.074249e-02_rb,1.999706e-02_rb,1.930546e-02_rb,1.866212e-02_rb,1.806221e-02_rb,&
- & 1.750152e-02_rb,1.697637e-02_rb,1.648352e-02_rb,1.602010e-02_rb,1.558358e-02_rb,&
- & 1.517172e-02_rb,1.478250e-02_rb,1.441413e-02_rb,1.406498e-02_rb,1.373362e-02_rb,&
- & 1.341872e-02_rb,1.311911e-02_rb,1.283371e-02_rb /)
- extice2(:, 21) = (/ &
-! band 21
- & 3.719909e-01_rb,2.259490e-01_rb,1.613144e-01_rb,1.250648e-01_rb,1.019462e-01_rb,&
- & 8.595358e-02_rb,7.425064e-02_rb,6.532618e-02_rb,5.830218e-02_rb,5.263421e-02_rb,&
- & 4.796697e-02_rb,4.405891e-02_rb,4.074013e-02_rb,3.788776e-02_rb,3.541071e-02_rb,&
- & 3.324008e-02_rb,3.132280e-02_rb,2.961733e-02_rb,2.809071e-02_rb,2.671645e-02_rb,&
- & 2.547302e-02_rb,2.434276e-02_rb,2.331102e-02_rb,2.236558e-02_rb,2.149614e-02_rb,&
- & 2.069397e-02_rb,1.995163e-02_rb,1.926272e-02_rb,1.862174e-02_rb,1.802389e-02_rb,&
- & 1.746500e-02_rb,1.694142e-02_rb,1.644994e-02_rb,1.598772e-02_rb,1.555225e-02_rb,&
- & 1.514129e-02_rb,1.475286e-02_rb,1.438515e-02_rb,1.403659e-02_rb,1.370572e-02_rb,&
- & 1.339124e-02_rb,1.309197e-02_rb,1.280685e-02_rb /)
- extice2(:, 22) = (/ &
-! band 22
- & 3.713158e-01_rb,2.253816e-01_rb,1.608461e-01_rb,1.246718e-01_rb,1.016109e-01_rb,&
- & 8.566332e-02_rb,7.399666e-02_rb,6.510199e-02_rb,5.810290e-02_rb,5.245608e-02_rb,&
- & 4.780702e-02_rb,4.391478e-02_rb,4.060989e-02_rb,3.776982e-02_rb,3.530374e-02_rb,&
- & 3.314296e-02_rb,3.123458e-02_rb,2.953719e-02_rb,2.801794e-02_rb,2.665043e-02_rb,&
- & 2.541321e-02_rb,2.428868e-02_rb,2.326224e-02_rb,2.232173e-02_rb,2.145688e-02_rb,&
- & 2.065899e-02_rb,1.992067e-02_rb,1.923552e-02_rb,1.859808e-02_rb,1.800356e-02_rb,&
- & 1.744782e-02_rb,1.692721e-02_rb,1.643855e-02_rb,1.597900e-02_rb,1.554606e-02_rb,&
- & 1.513751e-02_rb,1.475137e-02_rb,1.438586e-02_rb,1.403938e-02_rb,1.371050e-02_rb,&
- & 1.339793e-02_rb,1.310050e-02_rb,1.281713e-02_rb /)
- extice2(:, 23) = (/ &
-! band 23
- & 3.605883e-01_rb,2.204388e-01_rb,1.580431e-01_rb,1.229033e-01_rb,1.004203e-01_rb,&
- & 8.482616e-02_rb,7.338941e-02_rb,6.465105e-02_rb,5.776176e-02_rb,5.219398e-02_rb,&
- & 4.760288e-02_rb,4.375369e-02_rb,4.048111e-02_rb,3.766539e-02_rb,3.521771e-02_rb,&
- & 3.307079e-02_rb,3.117277e-02_rb,2.948303e-02_rb,2.796929e-02_rb,2.660560e-02_rb,&
- & 2.537086e-02_rb,2.424772e-02_rb,2.322182e-02_rb,2.228114e-02_rb,2.141556e-02_rb,&
- & 2.061649e-02_rb,1.987661e-02_rb,1.918962e-02_rb,1.855009e-02_rb,1.795330e-02_rb,&
- & 1.739514e-02_rb,1.687199e-02_rb,1.638069e-02_rb,1.591845e-02_rb,1.548276e-02_rb,&
- & 1.507143e-02_rb,1.468249e-02_rb,1.431416e-02_rb,1.396486e-02_rb,1.363318e-02_rb,&
- & 1.331781e-02_rb,1.301759e-02_rb,1.273147e-02_rb /)
- extice2(:, 24) = (/ &
-! band 24
- & 3.527890e-01_rb,2.168469e-01_rb,1.560090e-01_rb,1.216216e-01_rb,9.955787e-02_rb,&
- & 8.421942e-02_rb,7.294827e-02_rb,6.432192e-02_rb,5.751081e-02_rb,5.199888e-02_rb,&
- & 4.744835e-02_rb,4.362899e-02_rb,4.037847e-02_rb,3.757910e-02_rb,3.514351e-02_rb,&
- & 3.300546e-02_rb,3.111382e-02_rb,2.942853e-02_rb,2.791775e-02_rb,2.655584e-02_rb,&
- & 2.532195e-02_rb,2.419892e-02_rb,2.317255e-02_rb,2.223092e-02_rb,2.136402e-02_rb,&
- & 2.056334e-02_rb,1.982160e-02_rb,1.913258e-02_rb,1.849087e-02_rb,1.789178e-02_rb,&
- & 1.733124e-02_rb,1.680565e-02_rb,1.631187e-02_rb,1.584711e-02_rb,1.540889e-02_rb,&
- & 1.499502e-02_rb,1.460354e-02_rb,1.423269e-02_rb,1.388088e-02_rb,1.354670e-02_rb,&
- & 1.322887e-02_rb,1.292620e-02_rb,1.263767e-02_rb /)
- extice2(:, 25) = (/ &
-! band 25
- & 3.477874e-01_rb,2.143515e-01_rb,1.544887e-01_rb,1.205942e-01_rb,9.881779e-02_rb,&
- & 8.366261e-02_rb,7.251586e-02_rb,6.397790e-02_rb,5.723183e-02_rb,5.176908e-02_rb,&
- & 4.725658e-02_rb,4.346715e-02_rb,4.024055e-02_rb,3.746055e-02_rb,3.504080e-02_rb,&
- & 3.291583e-02_rb,3.103507e-02_rb,2.935891e-02_rb,2.785582e-02_rb,2.650042e-02_rb,&
- & 2.527206e-02_rb,2.415376e-02_rb,2.313142e-02_rb,2.219326e-02_rb,2.132934e-02_rb,&
- & 2.053122e-02_rb,1.979169e-02_rb,1.910456e-02_rb,1.846448e-02_rb,1.786680e-02_rb,&
- & 1.730745e-02_rb,1.678289e-02_rb,1.628998e-02_rb,1.582595e-02_rb,1.538835e-02_rb,&
- & 1.497499e-02_rb,1.458393e-02_rb,1.421341e-02_rb,1.386187e-02_rb,1.352788e-02_rb,&
- & 1.321019e-02_rb,1.290762e-02_rb,1.261913e-02_rb /)
- extice2(:, 26) = (/ &
-! band 26
- & 3.453721e-01_rb,2.130744e-01_rb,1.536698e-01_rb,1.200140e-01_rb,9.838078e-02_rb,&
- & 8.331940e-02_rb,7.223803e-02_rb,6.374775e-02_rb,5.703770e-02_rb,5.160290e-02_rb,&
- & 4.711259e-02_rb,4.334110e-02_rb,4.012923e-02_rb,3.736150e-02_rb,3.495208e-02_rb,&
- & 3.283589e-02_rb,3.096267e-02_rb,2.929302e-02_rb,2.779560e-02_rb,2.644517e-02_rb,&
- & 2.522119e-02_rb,2.410677e-02_rb,2.308788e-02_rb,2.215281e-02_rb,2.129165e-02_rb,&
- & 2.049602e-02_rb,1.975874e-02_rb,1.907365e-02_rb,1.843542e-02_rb,1.783943e-02_rb,&
- & 1.728162e-02_rb,1.675847e-02_rb,1.626685e-02_rb,1.580401e-02_rb,1.536750e-02_rb,&
- & 1.495515e-02_rb,1.456502e-02_rb,1.419537e-02_rb,1.384463e-02_rb,1.351139e-02_rb,&
- & 1.319438e-02_rb,1.289246e-02_rb,1.260456e-02_rb /)
- extice2(:, 27) = (/ &
-! band 27
- & 3.417883e-01_rb,2.113379e-01_rb,1.526395e-01_rb,1.193347e-01_rb,9.790253e-02_rb,&
- & 8.296715e-02_rb,7.196979e-02_rb,6.353806e-02_rb,5.687024e-02_rb,5.146670e-02_rb,&
- & 4.700001e-02_rb,4.324667e-02_rb,4.004894e-02_rb,3.729233e-02_rb,3.489172e-02_rb,&
- & 3.278257e-02_rb,3.091499e-02_rb,2.924987e-02_rb,2.775609e-02_rb,2.640859e-02_rb,&
- & 2.518695e-02_rb,2.407439e-02_rb,2.305697e-02_rb,2.212303e-02_rb,2.126273e-02_rb,&
- & 2.046774e-02_rb,1.973090e-02_rb,1.904610e-02_rb,1.840801e-02_rb,1.781204e-02_rb,&
- & 1.725417e-02_rb,1.673086e-02_rb,1.623902e-02_rb,1.577590e-02_rb,1.533906e-02_rb,&
- & 1.492634e-02_rb,1.453580e-02_rb,1.416571e-02_rb,1.381450e-02_rb,1.348078e-02_rb,&
- & 1.316327e-02_rb,1.286082e-02_rb,1.257240e-02_rb /)
- extice2(:, 28) = (/ &
-! band 28
- & 3.416111e-01_rb,2.114124e-01_rb,1.527734e-01_rb,1.194809e-01_rb,9.804612e-02_rb,&
- & 8.310287e-02_rb,7.209595e-02_rb,6.365442e-02_rb,5.697710e-02_rb,5.156460e-02_rb,&
- & 4.708957e-02_rb,4.332850e-02_rb,4.012361e-02_rb,3.736037e-02_rb,3.495364e-02_rb,&
- & 3.283879e-02_rb,3.096593e-02_rb,2.929589e-02_rb,2.779751e-02_rb,2.644571e-02_rb,&
- & 2.522004e-02_rb,2.410369e-02_rb,2.308271e-02_rb,2.214542e-02_rb,2.128195e-02_rb,&
- & 2.048396e-02_rb,1.974429e-02_rb,1.905679e-02_rb,1.841614e-02_rb,1.781774e-02_rb,&
- & 1.725754e-02_rb,1.673203e-02_rb,1.623807e-02_rb,1.577293e-02_rb,1.533416e-02_rb,&
- & 1.491958e-02_rb,1.452727e-02_rb,1.415547e-02_rb,1.380262e-02_rb,1.346732e-02_rb,&
- & 1.314830e-02_rb,1.284439e-02_rb,1.255456e-02_rb /)
- extice2(:, 29) = (/ &
-! band 29
- & 4.196611e-01_rb,2.493642e-01_rb,1.761261e-01_rb,1.357197e-01_rb,1.102161e-01_rb,&
- & 9.269376e-02_rb,7.992985e-02_rb,7.022538e-02_rb,6.260168e-02_rb,5.645603e-02_rb,&
- & 5.139732e-02_rb,4.716088e-02_rb,4.356133e-02_rb,4.046498e-02_rb,3.777303e-02_rb,&
- & 3.541094e-02_rb,3.332137e-02_rb,3.145954e-02_rb,2.978998e-02_rb,2.828419e-02_rb,&
- & 2.691905e-02_rb,2.567559e-02_rb,2.453811e-02_rb,2.349350e-02_rb,2.253072e-02_rb,&
- & 2.164042e-02_rb,2.081464e-02_rb,2.004652e-02_rb,1.933015e-02_rb,1.866041e-02_rb,&
- & 1.803283e-02_rb,1.744348e-02_rb,1.688894e-02_rb,1.636616e-02_rb,1.587244e-02_rb,&
- & 1.540539e-02_rb,1.496287e-02_rb,1.454295e-02_rb,1.414392e-02_rb,1.376423e-02_rb,&
- & 1.340247e-02_rb,1.305739e-02_rb,1.272784e-02_rb /)
-
-! single-scattering albedo: unitless
- ssaice2(:, 16) = (/ &
-! band 16
- & 6.630615e-01_rb,6.451169e-01_rb,6.333696e-01_rb,6.246927e-01_rb,6.178420e-01_rb,&
- & 6.121976e-01_rb,6.074069e-01_rb,6.032505e-01_rb,5.995830e-01_rb,5.963030e-01_rb,&
- & 5.933372e-01_rb,5.906311e-01_rb,5.881427e-01_rb,5.858395e-01_rb,5.836955e-01_rb,&
- & 5.816896e-01_rb,5.798046e-01_rb,5.780264e-01_rb,5.763429e-01_rb,5.747441e-01_rb,&
- & 5.732213e-01_rb,5.717672e-01_rb,5.703754e-01_rb,5.690403e-01_rb,5.677571e-01_rb,&
- & 5.665215e-01_rb,5.653297e-01_rb,5.641782e-01_rb,5.630643e-01_rb,5.619850e-01_rb,&
- & 5.609381e-01_rb,5.599214e-01_rb,5.589328e-01_rb,5.579707e-01_rb,5.570333e-01_rb,&
- & 5.561193e-01_rb,5.552272e-01_rb,5.543558e-01_rb,5.535041e-01_rb,5.526708e-01_rb,&
- & 5.518551e-01_rb,5.510561e-01_rb,5.502729e-01_rb /)
- ssaice2(:, 17) = (/ &
-! band 17
- & 7.689749e-01_rb,7.398171e-01_rb,7.205819e-01_rb,7.065690e-01_rb,6.956928e-01_rb,&
- & 6.868989e-01_rb,6.795813e-01_rb,6.733606e-01_rb,6.679838e-01_rb,6.632742e-01_rb,&
- & 6.591036e-01_rb,6.553766e-01_rb,6.520197e-01_rb,6.489757e-01_rb,6.461991e-01_rb,&
- & 6.436531e-01_rb,6.413075e-01_rb,6.391375e-01_rb,6.371221e-01_rb,6.352438e-01_rb,&
- & 6.334876e-01_rb,6.318406e-01_rb,6.302918e-01_rb,6.288315e-01_rb,6.274512e-01_rb,&
- & 6.261436e-01_rb,6.249022e-01_rb,6.237211e-01_rb,6.225953e-01_rb,6.215201e-01_rb,&
- & 6.204914e-01_rb,6.195055e-01_rb,6.185592e-01_rb,6.176492e-01_rb,6.167730e-01_rb,&
- & 6.159280e-01_rb,6.151120e-01_rb,6.143228e-01_rb,6.135587e-01_rb,6.128177e-01_rb,&
- & 6.120984e-01_rb,6.113993e-01_rb,6.107189e-01_rb /)
- ssaice2(:, 18) = (/ &
-! band 18
- & 9.956167e-01_rb,9.814770e-01_rb,9.716104e-01_rb,9.639746e-01_rb,9.577179e-01_rb,&
- & 9.524010e-01_rb,9.477672e-01_rb,9.436527e-01_rb,9.399467e-01_rb,9.365708e-01_rb,&
- & 9.334672e-01_rb,9.305921e-01_rb,9.279118e-01_rb,9.253993e-01_rb,9.230330e-01_rb,&
- & 9.207954e-01_rb,9.186719e-01_rb,9.166501e-01_rb,9.147199e-01_rb,9.128722e-01_rb,&
- & 9.110997e-01_rb,9.093956e-01_rb,9.077544e-01_rb,9.061708e-01_rb,9.046406e-01_rb,&
- & 9.031598e-01_rb,9.017248e-01_rb,9.003326e-01_rb,8.989804e-01_rb,8.976655e-01_rb,&
- & 8.963857e-01_rb,8.951389e-01_rb,8.939233e-01_rb,8.927370e-01_rb,8.915785e-01_rb,&
- & 8.904464e-01_rb,8.893392e-01_rb,8.882559e-01_rb,8.871951e-01_rb,8.861559e-01_rb,&
- & 8.851373e-01_rb,8.841383e-01_rb,8.831581e-01_rb /)
- ssaice2(:, 19) = (/ &
-! band 19
- & 9.723177e-01_rb,9.452119e-01_rb,9.267592e-01_rb,9.127393e-01_rb,9.014238e-01_rb,&
- & 8.919334e-01_rb,8.837584e-01_rb,8.765773e-01_rb,8.701736e-01_rb,8.643950e-01_rb,&
- & 8.591299e-01_rb,8.542942e-01_rb,8.498230e-01_rb,8.456651e-01_rb,8.417794e-01_rb,&
- & 8.381324e-01_rb,8.346964e-01_rb,8.314484e-01_rb,8.283687e-01_rb,8.254408e-01_rb,&
- & 8.226505e-01_rb,8.199854e-01_rb,8.174348e-01_rb,8.149891e-01_rb,8.126403e-01_rb,&
- & 8.103808e-01_rb,8.082041e-01_rb,8.061044e-01_rb,8.040765e-01_rb,8.021156e-01_rb,&
- & 8.002174e-01_rb,7.983781e-01_rb,7.965941e-01_rb,7.948622e-01_rb,7.931795e-01_rb,&
- & 7.915432e-01_rb,7.899508e-01_rb,7.884002e-01_rb,7.868891e-01_rb,7.854156e-01_rb,&
- & 7.839779e-01_rb,7.825742e-01_rb,7.812031e-01_rb /)
- ssaice2(:, 20) = (/ &
-! band 20
- & 9.933294e-01_rb,9.860917e-01_rb,9.811564e-01_rb,9.774008e-01_rb,9.743652e-01_rb,&
- & 9.718155e-01_rb,9.696159e-01_rb,9.676810e-01_rb,9.659531e-01_rb,9.643915e-01_rb,&
- & 9.629667e-01_rb,9.616561e-01_rb,9.604426e-01_rb,9.593125e-01_rb,9.582548e-01_rb,&
- & 9.572607e-01_rb,9.563227e-01_rb,9.554347e-01_rb,9.545915e-01_rb,9.537888e-01_rb,&
- & 9.530226e-01_rb,9.522898e-01_rb,9.515874e-01_rb,9.509130e-01_rb,9.502643e-01_rb,&
- & 9.496394e-01_rb,9.490366e-01_rb,9.484542e-01_rb,9.478910e-01_rb,9.473456e-01_rb,&
- & 9.468169e-01_rb,9.463039e-01_rb,9.458056e-01_rb,9.453212e-01_rb,9.448499e-01_rb,&
- & 9.443910e-01_rb,9.439438e-01_rb,9.435077e-01_rb,9.430821e-01_rb,9.426666e-01_rb,&
- & 9.422607e-01_rb,9.418638e-01_rb,9.414756e-01_rb /)
- ssaice2(:, 21) = (/ &
-! band 21
- & 9.900787e-01_rb,9.828880e-01_rb,9.779258e-01_rb,9.741173e-01_rb,9.710184e-01_rb,&
- & 9.684012e-01_rb,9.661332e-01_rb,9.641301e-01_rb,9.623352e-01_rb,9.607083e-01_rb,&
- & 9.592198e-01_rb,9.578474e-01_rb,9.565739e-01_rb,9.553856e-01_rb,9.542715e-01_rb,&
- & 9.532226e-01_rb,9.522314e-01_rb,9.512919e-01_rb,9.503986e-01_rb,9.495472e-01_rb,&
- & 9.487337e-01_rb,9.479549e-01_rb,9.472077e-01_rb,9.464897e-01_rb,9.457985e-01_rb,&
- & 9.451322e-01_rb,9.444890e-01_rb,9.438673e-01_rb,9.432656e-01_rb,9.426826e-01_rb,&
- & 9.421173e-01_rb,9.415684e-01_rb,9.410351e-01_rb,9.405164e-01_rb,9.400115e-01_rb,&
- & 9.395198e-01_rb,9.390404e-01_rb,9.385728e-01_rb,9.381164e-01_rb,9.376707e-01_rb,&
- & 9.372350e-01_rb,9.368091e-01_rb,9.363923e-01_rb /)
- ssaice2(:, 22) = (/ &
-! band 22
- & 9.986793e-01_rb,9.985239e-01_rb,9.983911e-01_rb,9.982715e-01_rb,9.981606e-01_rb,&
- & 9.980562e-01_rb,9.979567e-01_rb,9.978613e-01_rb,9.977691e-01_rb,9.976798e-01_rb,&
- & 9.975929e-01_rb,9.975081e-01_rb,9.974251e-01_rb,9.973438e-01_rb,9.972640e-01_rb,&
- & 9.971855e-01_rb,9.971083e-01_rb,9.970322e-01_rb,9.969571e-01_rb,9.968830e-01_rb,&
- & 9.968099e-01_rb,9.967375e-01_rb,9.966660e-01_rb,9.965951e-01_rb,9.965250e-01_rb,&
- & 9.964555e-01_rb,9.963867e-01_rb,9.963185e-01_rb,9.962508e-01_rb,9.961836e-01_rb,&
- & 9.961170e-01_rb,9.960508e-01_rb,9.959851e-01_rb,9.959198e-01_rb,9.958550e-01_rb,&
- & 9.957906e-01_rb,9.957266e-01_rb,9.956629e-01_rb,9.955997e-01_rb,9.955367e-01_rb,&
- & 9.954742e-01_rb,9.954119e-01_rb,9.953500e-01_rb /)
- ssaice2(:, 23) = (/ &
-! band 23
- & 9.997944e-01_rb,9.997791e-01_rb,9.997664e-01_rb,9.997547e-01_rb,9.997436e-01_rb,&
- & 9.997327e-01_rb,9.997219e-01_rb,9.997110e-01_rb,9.996999e-01_rb,9.996886e-01_rb,&
- & 9.996771e-01_rb,9.996653e-01_rb,9.996533e-01_rb,9.996409e-01_rb,9.996282e-01_rb,&
- & 9.996152e-01_rb,9.996019e-01_rb,9.995883e-01_rb,9.995743e-01_rb,9.995599e-01_rb,&
- & 9.995453e-01_rb,9.995302e-01_rb,9.995149e-01_rb,9.994992e-01_rb,9.994831e-01_rb,&
- & 9.994667e-01_rb,9.994500e-01_rb,9.994329e-01_rb,9.994154e-01_rb,9.993976e-01_rb,&
- & 9.993795e-01_rb,9.993610e-01_rb,9.993422e-01_rb,9.993230e-01_rb,9.993035e-01_rb,&
- & 9.992837e-01_rb,9.992635e-01_rb,9.992429e-01_rb,9.992221e-01_rb,9.992008e-01_rb,&
- & 9.991793e-01_rb,9.991574e-01_rb,9.991352e-01_rb /)
- ssaice2(:, 24) = (/ &
-! band 24
- & 9.999949e-01_rb,9.999947e-01_rb,9.999943e-01_rb,9.999939e-01_rb,9.999934e-01_rb,&
- & 9.999927e-01_rb,9.999920e-01_rb,9.999913e-01_rb,9.999904e-01_rb,9.999895e-01_rb,&
- & 9.999885e-01_rb,9.999874e-01_rb,9.999863e-01_rb,9.999851e-01_rb,9.999838e-01_rb,&
- & 9.999824e-01_rb,9.999810e-01_rb,9.999795e-01_rb,9.999780e-01_rb,9.999764e-01_rb,&
- & 9.999747e-01_rb,9.999729e-01_rb,9.999711e-01_rb,9.999692e-01_rb,9.999673e-01_rb,&
- & 9.999653e-01_rb,9.999632e-01_rb,9.999611e-01_rb,9.999589e-01_rb,9.999566e-01_rb,&
- & 9.999543e-01_rb,9.999519e-01_rb,9.999495e-01_rb,9.999470e-01_rb,9.999444e-01_rb,&
- & 9.999418e-01_rb,9.999392e-01_rb,9.999364e-01_rb,9.999336e-01_rb,9.999308e-01_rb,&
- & 9.999279e-01_rb,9.999249e-01_rb,9.999219e-01_rb /)
- ssaice2(:, 25) = (/ &
-! band 25
- & 9.999997e-01_rb,9.999997e-01_rb,9.999997e-01_rb,9.999996e-01_rb,9.999996e-01_rb,&
- & 9.999995e-01_rb,9.999994e-01_rb,9.999993e-01_rb,9.999993e-01_rb,9.999992e-01_rb,&
- & 9.999991e-01_rb,9.999989e-01_rb,9.999988e-01_rb,9.999987e-01_rb,9.999986e-01_rb,&
- & 9.999984e-01_rb,9.999983e-01_rb,9.999981e-01_rb,9.999980e-01_rb,9.999978e-01_rb,&
- & 9.999976e-01_rb,9.999974e-01_rb,9.999972e-01_rb,9.999971e-01_rb,9.999969e-01_rb,&
- & 9.999966e-01_rb,9.999964e-01_rb,9.999962e-01_rb,9.999960e-01_rb,9.999957e-01_rb,&
- & 9.999955e-01_rb,9.999953e-01_rb,9.999950e-01_rb,9.999947e-01_rb,9.999945e-01_rb,&
- & 9.999942e-01_rb,9.999939e-01_rb,9.999936e-01_rb,9.999934e-01_rb,9.999931e-01_rb,&
- & 9.999928e-01_rb,9.999925e-01_rb,9.999921e-01_rb /)
- ssaice2(:, 26) = (/ &
-! band 26
- & 9.999997e-01_rb,9.999996e-01_rb,9.999996e-01_rb,9.999995e-01_rb,9.999994e-01_rb,&
- & 9.999993e-01_rb,9.999992e-01_rb,9.999991e-01_rb,9.999990e-01_rb,9.999989e-01_rb,&
- & 9.999987e-01_rb,9.999986e-01_rb,9.999984e-01_rb,9.999982e-01_rb,9.999980e-01_rb,&
- & 9.999978e-01_rb,9.999976e-01_rb,9.999974e-01_rb,9.999972e-01_rb,9.999970e-01_rb,&
- & 9.999967e-01_rb,9.999965e-01_rb,9.999962e-01_rb,9.999959e-01_rb,9.999956e-01_rb,&
- & 9.999954e-01_rb,9.999951e-01_rb,9.999947e-01_rb,9.999944e-01_rb,9.999941e-01_rb,&
- & 9.999938e-01_rb,9.999934e-01_rb,9.999931e-01_rb,9.999927e-01_rb,9.999923e-01_rb,&
- & 9.999920e-01_rb,9.999916e-01_rb,9.999912e-01_rb,9.999908e-01_rb,9.999904e-01_rb,&
- & 9.999899e-01_rb,9.999895e-01_rb,9.999891e-01_rb /)
- ssaice2(:, 27) = (/ &
-! band 27
- & 9.999987e-01_rb,9.999987e-01_rb,9.999985e-01_rb,9.999984e-01_rb,9.999982e-01_rb,&
- & 9.999980e-01_rb,9.999978e-01_rb,9.999976e-01_rb,9.999973e-01_rb,9.999970e-01_rb,&
- & 9.999967e-01_rb,9.999964e-01_rb,9.999960e-01_rb,9.999956e-01_rb,9.999952e-01_rb,&
- & 9.999948e-01_rb,9.999944e-01_rb,9.999939e-01_rb,9.999934e-01_rb,9.999929e-01_rb,&
- & 9.999924e-01_rb,9.999918e-01_rb,9.999913e-01_rb,9.999907e-01_rb,9.999901e-01_rb,&
- & 9.999894e-01_rb,9.999888e-01_rb,9.999881e-01_rb,9.999874e-01_rb,9.999867e-01_rb,&
- & 9.999860e-01_rb,9.999853e-01_rb,9.999845e-01_rb,9.999837e-01_rb,9.999829e-01_rb,&
- & 9.999821e-01_rb,9.999813e-01_rb,9.999804e-01_rb,9.999796e-01_rb,9.999787e-01_rb,&
- & 9.999778e-01_rb,9.999768e-01_rb,9.999759e-01_rb /)
- ssaice2(:, 28) = (/ &
-! band 28
- & 9.999989e-01_rb,9.999989e-01_rb,9.999987e-01_rb,9.999986e-01_rb,9.999984e-01_rb,&
- & 9.999982e-01_rb,9.999980e-01_rb,9.999978e-01_rb,9.999975e-01_rb,9.999972e-01_rb,&
- & 9.999969e-01_rb,9.999966e-01_rb,9.999962e-01_rb,9.999958e-01_rb,9.999954e-01_rb,&
- & 9.999950e-01_rb,9.999945e-01_rb,9.999941e-01_rb,9.999936e-01_rb,9.999931e-01_rb,&
- & 9.999925e-01_rb,9.999920e-01_rb,9.999914e-01_rb,9.999908e-01_rb,9.999902e-01_rb,&
- & 9.999896e-01_rb,9.999889e-01_rb,9.999883e-01_rb,9.999876e-01_rb,9.999869e-01_rb,&
- & 9.999861e-01_rb,9.999854e-01_rb,9.999846e-01_rb,9.999838e-01_rb,9.999830e-01_rb,&
- & 9.999822e-01_rb,9.999814e-01_rb,9.999805e-01_rb,9.999796e-01_rb,9.999787e-01_rb,&
- & 9.999778e-01_rb,9.999769e-01_rb,9.999759e-01_rb /)
- ssaice2(:, 29) = (/ &
-! band 29
- & 7.042143e-01_rb,6.691161e-01_rb,6.463240e-01_rb,6.296590e-01_rb,6.166381e-01_rb,&
- & 6.060183e-01_rb,5.970908e-01_rb,5.894144e-01_rb,5.826968e-01_rb,5.767343e-01_rb,&
- & 5.713804e-01_rb,5.665256e-01_rb,5.620867e-01_rb,5.579987e-01_rb,5.542101e-01_rb,&
- & 5.506794e-01_rb,5.473727e-01_rb,5.442620e-01_rb,5.413239e-01_rb,5.385389e-01_rb,&
- & 5.358901e-01_rb,5.333633e-01_rb,5.309460e-01_rb,5.286277e-01_rb,5.263988e-01_rb,&
- & 5.242512e-01_rb,5.221777e-01_rb,5.201719e-01_rb,5.182280e-01_rb,5.163410e-01_rb,&
- & 5.145062e-01_rb,5.127197e-01_rb,5.109776e-01_rb,5.092766e-01_rb,5.076137e-01_rb,&
- & 5.059860e-01_rb,5.043911e-01_rb,5.028266e-01_rb,5.012904e-01_rb,4.997805e-01_rb,&
- & 4.982951e-01_rb,4.968326e-01_rb,4.953913e-01_rb /)
-
-! asymmetry factor: unitless
- asyice2(:, 16) = (/ &
-! band 16
- & 7.946655e-01_rb,8.547685e-01_rb,8.806016e-01_rb,8.949880e-01_rb,9.041676e-01_rb,&
- & 9.105399e-01_rb,9.152249e-01_rb,9.188160e-01_rb,9.216573e-01_rb,9.239620e-01_rb,&
- & 9.258695e-01_rb,9.274745e-01_rb,9.288441e-01_rb,9.300267e-01_rb,9.310584e-01_rb,&
- & 9.319665e-01_rb,9.327721e-01_rb,9.334918e-01_rb,9.341387e-01_rb,9.347236e-01_rb,&
- & 9.352551e-01_rb,9.357402e-01_rb,9.361850e-01_rb,9.365942e-01_rb,9.369722e-01_rb,&
- & 9.373225e-01_rb,9.376481e-01_rb,9.379516e-01_rb,9.382352e-01_rb,9.385010e-01_rb,&
- & 9.387505e-01_rb,9.389854e-01_rb,9.392070e-01_rb,9.394163e-01_rb,9.396145e-01_rb,&
- & 9.398024e-01_rb,9.399809e-01_rb,9.401508e-01_rb,9.403126e-01_rb,9.404670e-01_rb,&
- & 9.406144e-01_rb,9.407555e-01_rb,9.408906e-01_rb /)
- asyice2(:, 17) = (/ &
-! band 17
- & 9.078091e-01_rb,9.195850e-01_rb,9.267250e-01_rb,9.317083e-01_rb,9.354632e-01_rb,&
- & 9.384323e-01_rb,9.408597e-01_rb,9.428935e-01_rb,9.446301e-01_rb,9.461351e-01_rb,&
- & 9.474555e-01_rb,9.486259e-01_rb,9.496722e-01_rb,9.506146e-01_rb,9.514688e-01_rb,&
- & 9.522476e-01_rb,9.529612e-01_rb,9.536181e-01_rb,9.542251e-01_rb,9.547883e-01_rb,&
- & 9.553124e-01_rb,9.558019e-01_rb,9.562601e-01_rb,9.566904e-01_rb,9.570953e-01_rb,&
- & 9.574773e-01_rb,9.578385e-01_rb,9.581806e-01_rb,9.585054e-01_rb,9.588142e-01_rb,&
- & 9.591083e-01_rb,9.593888e-01_rb,9.596569e-01_rb,9.599135e-01_rb,9.601593e-01_rb,&
- & 9.603952e-01_rb,9.606219e-01_rb,9.608399e-01_rb,9.610499e-01_rb,9.612523e-01_rb,&
- & 9.614477e-01_rb,9.616365e-01_rb,9.618192e-01_rb /)
- asyice2(:, 18) = (/ &
-! band 18
- & 8.322045e-01_rb,8.528693e-01_rb,8.648167e-01_rb,8.729163e-01_rb,8.789054e-01_rb,&
- & 8.835845e-01_rb,8.873819e-01_rb,8.905511e-01_rb,8.932532e-01_rb,8.955965e-01_rb,&
- & 8.976567e-01_rb,8.994887e-01_rb,9.011334e-01_rb,9.026221e-01_rb,9.039791e-01_rb,&
- & 9.052237e-01_rb,9.063715e-01_rb,9.074349e-01_rb,9.084245e-01_rb,9.093489e-01_rb,&
- & 9.102154e-01_rb,9.110303e-01_rb,9.117987e-01_rb,9.125253e-01_rb,9.132140e-01_rb,&
- & 9.138682e-01_rb,9.144910e-01_rb,9.150850e-01_rb,9.156524e-01_rb,9.161955e-01_rb,&
- & 9.167160e-01_rb,9.172157e-01_rb,9.176959e-01_rb,9.181581e-01_rb,9.186034e-01_rb,&
- & 9.190330e-01_rb,9.194478e-01_rb,9.198488e-01_rb,9.202368e-01_rb,9.206126e-01_rb,&
- & 9.209768e-01_rb,9.213301e-01_rb,9.216731e-01_rb /)
- asyice2(:, 19) = (/ &
-! band 19
- & 8.116560e-01_rb,8.488278e-01_rb,8.674331e-01_rb,8.788148e-01_rb,8.865810e-01_rb,&
- & 8.922595e-01_rb,8.966149e-01_rb,9.000747e-01_rb,9.028980e-01_rb,9.052513e-01_rb,&
- & 9.072468e-01_rb,9.089632e-01_rb,9.104574e-01_rb,9.117713e-01_rb,9.129371e-01_rb,&
- & 9.139793e-01_rb,9.149174e-01_rb,9.157668e-01_rb,9.165400e-01_rb,9.172473e-01_rb,&
- & 9.178970e-01_rb,9.184962e-01_rb,9.190508e-01_rb,9.195658e-01_rb,9.200455e-01_rb,&
- & 9.204935e-01_rb,9.209130e-01_rb,9.213067e-01_rb,9.216771e-01_rb,9.220262e-01_rb,&
- & 9.223560e-01_rb,9.226680e-01_rb,9.229636e-01_rb,9.232443e-01_rb,9.235112e-01_rb,&
- & 9.237652e-01_rb,9.240074e-01_rb,9.242385e-01_rb,9.244594e-01_rb,9.246708e-01_rb,&
- & 9.248733e-01_rb,9.250674e-01_rb,9.252536e-01_rb /)
- asyice2(:, 20) = (/ &
-! band 20
- & 8.047113e-01_rb,8.402864e-01_rb,8.570332e-01_rb,8.668455e-01_rb,8.733206e-01_rb,&
- & 8.779272e-01_rb,8.813796e-01_rb,8.840676e-01_rb,8.862225e-01_rb,8.879904e-01_rb,&
- & 8.894682e-01_rb,8.907228e-01_rb,8.918019e-01_rb,8.927404e-01_rb,8.935645e-01_rb,&
- & 8.942943e-01_rb,8.949452e-01_rb,8.955296e-01_rb,8.960574e-01_rb,8.965366e-01_rb,&
- & 8.969736e-01_rb,8.973740e-01_rb,8.977422e-01_rb,8.980820e-01_rb,8.983966e-01_rb,&
- & 8.986889e-01_rb,8.989611e-01_rb,8.992153e-01_rb,8.994533e-01_rb,8.996766e-01_rb,&
- & 8.998865e-01_rb,9.000843e-01_rb,9.002709e-01_rb,9.004474e-01_rb,9.006146e-01_rb,&
- & 9.007731e-01_rb,9.009237e-01_rb,9.010670e-01_rb,9.012034e-01_rb,9.013336e-01_rb,&
- & 9.014579e-01_rb,9.015767e-01_rb,9.016904e-01_rb /)
- asyice2(:, 21) = (/ &
-! band 21
- & 8.179122e-01_rb,8.480726e-01_rb,8.621945e-01_rb,8.704354e-01_rb,8.758555e-01_rb,&
- & 8.797007e-01_rb,8.825750e-01_rb,8.848078e-01_rb,8.865939e-01_rb,8.880564e-01_rb,&
- & 8.892765e-01_rb,8.903105e-01_rb,8.911982e-01_rb,8.919689e-01_rb,8.926446e-01_rb,&
- & 8.932419e-01_rb,8.937738e-01_rb,8.942506e-01_rb,8.946806e-01_rb,8.950702e-01_rb,&
- & 8.954251e-01_rb,8.957497e-01_rb,8.960477e-01_rb,8.963223e-01_rb,8.965762e-01_rb,&
- & 8.968116e-01_rb,8.970306e-01_rb,8.972347e-01_rb,8.974255e-01_rb,8.976042e-01_rb,&
- & 8.977720e-01_rb,8.979298e-01_rb,8.980784e-01_rb,8.982188e-01_rb,8.983515e-01_rb,&
- & 8.984771e-01_rb,8.985963e-01_rb,8.987095e-01_rb,8.988171e-01_rb,8.989195e-01_rb,&
- & 8.990172e-01_rb,8.991104e-01_rb,8.991994e-01_rb /)
- asyice2(:, 22) = (/ &
-! band 22
- & 8.169789e-01_rb,8.455024e-01_rb,8.586925e-01_rb,8.663283e-01_rb,8.713217e-01_rb,&
- & 8.748488e-01_rb,8.774765e-01_rb,8.795122e-01_rb,8.811370e-01_rb,8.824649e-01_rb,&
- & 8.835711e-01_rb,8.845073e-01_rb,8.853103e-01_rb,8.860068e-01_rb,8.866170e-01_rb,&
- & 8.871560e-01_rb,8.876358e-01_rb,8.880658e-01_rb,8.884533e-01_rb,8.888044e-01_rb,&
- & 8.891242e-01_rb,8.894166e-01_rb,8.896851e-01_rb,8.899324e-01_rb,8.901612e-01_rb,&
- & 8.903733e-01_rb,8.905706e-01_rb,8.907545e-01_rb,8.909265e-01_rb,8.910876e-01_rb,&
- & 8.912388e-01_rb,8.913812e-01_rb,8.915153e-01_rb,8.916419e-01_rb,8.917617e-01_rb,&
- & 8.918752e-01_rb,8.919829e-01_rb,8.920851e-01_rb,8.921824e-01_rb,8.922751e-01_rb,&
- & 8.923635e-01_rb,8.924478e-01_rb,8.925284e-01_rb /)
- asyice2(:, 23) = (/ &
-! band 23
- & 8.387642e-01_rb,8.569979e-01_rb,8.658630e-01_rb,8.711825e-01_rb,8.747605e-01_rb,&
- & 8.773472e-01_rb,8.793129e-01_rb,8.808621e-01_rb,8.821179e-01_rb,8.831583e-01_rb,&
- & 8.840361e-01_rb,8.847875e-01_rb,8.854388e-01_rb,8.860094e-01_rb,8.865138e-01_rb,&
- & 8.869634e-01_rb,8.873668e-01_rb,8.877310e-01_rb,8.880617e-01_rb,8.883635e-01_rb,&
- & 8.886401e-01_rb,8.888947e-01_rb,8.891298e-01_rb,8.893477e-01_rb,8.895504e-01_rb,&
- & 8.897393e-01_rb,8.899159e-01_rb,8.900815e-01_rb,8.902370e-01_rb,8.903833e-01_rb,&
- & 8.905214e-01_rb,8.906518e-01_rb,8.907753e-01_rb,8.908924e-01_rb,8.910036e-01_rb,&
- & 8.911094e-01_rb,8.912101e-01_rb,8.913062e-01_rb,8.913979e-01_rb,8.914856e-01_rb,&
- & 8.915695e-01_rb,8.916498e-01_rb,8.917269e-01_rb /)
- asyice2(:, 24) = (/ &
-! band 24
- & 8.522208e-01_rb,8.648132e-01_rb,8.711224e-01_rb,8.749901e-01_rb,8.776354e-01_rb,&
- & 8.795743e-01_rb,8.810649e-01_rb,8.822518e-01_rb,8.832225e-01_rb,8.840333e-01_rb,&
- & 8.847224e-01_rb,8.853162e-01_rb,8.858342e-01_rb,8.862906e-01_rb,8.866962e-01_rb,&
- & 8.870595e-01_rb,8.873871e-01_rb,8.876842e-01_rb,8.879551e-01_rb,8.882032e-01_rb,&
- & 8.884316e-01_rb,8.886425e-01_rb,8.888380e-01_rb,8.890199e-01_rb,8.891895e-01_rb,&
- & 8.893481e-01_rb,8.894968e-01_rb,8.896366e-01_rb,8.897683e-01_rb,8.898926e-01_rb,&
- & 8.900102e-01_rb,8.901215e-01_rb,8.902272e-01_rb,8.903276e-01_rb,8.904232e-01_rb,&
- & 8.905144e-01_rb,8.906014e-01_rb,8.906845e-01_rb,8.907640e-01_rb,8.908402e-01_rb,&
- & 8.909132e-01_rb,8.909834e-01_rb,8.910507e-01_rb /)
- asyice2(:, 25) = (/ &
-! band 25
- & 8.578202e-01_rb,8.683033e-01_rb,8.735431e-01_rb,8.767488e-01_rb,8.789378e-01_rb,&
- & 8.805399e-01_rb,8.817701e-01_rb,8.827485e-01_rb,8.835480e-01_rb,8.842152e-01_rb,&
- & 8.847817e-01_rb,8.852696e-01_rb,8.856949e-01_rb,8.860694e-01_rb,8.864020e-01_rb,&
- & 8.866997e-01_rb,8.869681e-01_rb,8.872113e-01_rb,8.874330e-01_rb,8.876360e-01_rb,&
- & 8.878227e-01_rb,8.879951e-01_rb,8.881548e-01_rb,8.883033e-01_rb,8.884418e-01_rb,&
- & 8.885712e-01_rb,8.886926e-01_rb,8.888066e-01_rb,8.889139e-01_rb,8.890152e-01_rb,&
- & 8.891110e-01_rb,8.892017e-01_rb,8.892877e-01_rb,8.893695e-01_rb,8.894473e-01_rb,&
- & 8.895214e-01_rb,8.895921e-01_rb,8.896597e-01_rb,8.897243e-01_rb,8.897862e-01_rb,&
- & 8.898456e-01_rb,8.899025e-01_rb,8.899572e-01_rb /)
- asyice2(:, 26) = (/ &
-! band 26
- & 8.625615e-01_rb,8.713831e-01_rb,8.755799e-01_rb,8.780560e-01_rb,8.796983e-01_rb,&
- & 8.808714e-01_rb,8.817534e-01_rb,8.824420e-01_rb,8.829953e-01_rb,8.834501e-01_rb,&
- & 8.838310e-01_rb,8.841549e-01_rb,8.844338e-01_rb,8.846767e-01_rb,8.848902e-01_rb,&
- & 8.850795e-01_rb,8.852484e-01_rb,8.854002e-01_rb,8.855374e-01_rb,8.856620e-01_rb,&
- & 8.857758e-01_rb,8.858800e-01_rb,8.859759e-01_rb,8.860644e-01_rb,8.861464e-01_rb,&
- & 8.862225e-01_rb,8.862935e-01_rb,8.863598e-01_rb,8.864218e-01_rb,8.864800e-01_rb,&
- & 8.865347e-01_rb,8.865863e-01_rb,8.866349e-01_rb,8.866809e-01_rb,8.867245e-01_rb,&
- & 8.867658e-01_rb,8.868050e-01_rb,8.868423e-01_rb,8.868778e-01_rb,8.869117e-01_rb,&
- & 8.869440e-01_rb,8.869749e-01_rb,8.870044e-01_rb /)
- asyice2(:, 27) = (/ &
-! band 27
- & 8.587495e-01_rb,8.684764e-01_rb,8.728189e-01_rb,8.752872e-01_rb,8.768846e-01_rb,&
- & 8.780060e-01_rb,8.788386e-01_rb,8.794824e-01_rb,8.799960e-01_rb,8.804159e-01_rb,&
- & 8.807660e-01_rb,8.810626e-01_rb,8.813175e-01_rb,8.815390e-01_rb,8.817335e-01_rb,&
- & 8.819057e-01_rb,8.820593e-01_rb,8.821973e-01_rb,8.823220e-01_rb,8.824353e-01_rb,&
- & 8.825387e-01_rb,8.826336e-01_rb,8.827209e-01_rb,8.828016e-01_rb,8.828764e-01_rb,&
- & 8.829459e-01_rb,8.830108e-01_rb,8.830715e-01_rb,8.831283e-01_rb,8.831817e-01_rb,&
- & 8.832320e-01_rb,8.832795e-01_rb,8.833244e-01_rb,8.833668e-01_rb,8.834071e-01_rb,&
- & 8.834454e-01_rb,8.834817e-01_rb,8.835164e-01_rb,8.835495e-01_rb,8.835811e-01_rb,&
- & 8.836113e-01_rb,8.836402e-01_rb,8.836679e-01_rb /)
- asyice2(:, 28) = (/ &
-! band 28
- & 8.561110e-01_rb,8.678583e-01_rb,8.727554e-01_rb,8.753892e-01_rb,8.770154e-01_rb,&
- & 8.781109e-01_rb,8.788949e-01_rb,8.794812e-01_rb,8.799348e-01_rb,8.802952e-01_rb,&
- & 8.805880e-01_rb,8.808300e-01_rb,8.810331e-01_rb,8.812058e-01_rb,8.813543e-01_rb,&
- & 8.814832e-01_rb,8.815960e-01_rb,8.816956e-01_rb,8.817839e-01_rb,8.818629e-01_rb,&
- & 8.819339e-01_rb,8.819979e-01_rb,8.820560e-01_rb,8.821089e-01_rb,8.821573e-01_rb,&
- & 8.822016e-01_rb,8.822425e-01_rb,8.822801e-01_rb,8.823150e-01_rb,8.823474e-01_rb,&
- & 8.823775e-01_rb,8.824056e-01_rb,8.824318e-01_rb,8.824564e-01_rb,8.824795e-01_rb,&
- & 8.825011e-01_rb,8.825215e-01_rb,8.825408e-01_rb,8.825589e-01_rb,8.825761e-01_rb,&
- & 8.825924e-01_rb,8.826078e-01_rb,8.826224e-01_rb /)
- asyice2(:, 29) = (/ &
-! band 29
- & 8.311124e-01_rb,8.688197e-01_rb,8.900274e-01_rb,9.040696e-01_rb,9.142334e-01_rb,&
- & 9.220181e-01_rb,9.282195e-01_rb,9.333048e-01_rb,9.375689e-01_rb,9.412085e-01_rb,&
- & 9.443604e-01_rb,9.471230e-01_rb,9.495694e-01_rb,9.517549e-01_rb,9.537224e-01_rb,&
- & 9.555057e-01_rb,9.571316e-01_rb,9.586222e-01_rb,9.599952e-01_rb,9.612656e-01_rb,&
- & 9.624458e-01_rb,9.635461e-01_rb,9.645756e-01_rb,9.655418e-01_rb,9.664513e-01_rb,&
- & 9.673098e-01_rb,9.681222e-01_rb,9.688928e-01_rb,9.696256e-01_rb,9.703237e-01_rb,&
- & 9.709903e-01_rb,9.716280e-01_rb,9.722391e-01_rb,9.728258e-01_rb,9.733901e-01_rb,&
- & 9.739336e-01_rb,9.744579e-01_rb,9.749645e-01_rb,9.754546e-01_rb,9.759294e-01_rb,&
- & 9.763901e-01_rb,9.768376e-01_rb,9.772727e-01_rb /)
-
-! Hexagonal Ice Particle Parameterization
-! extinction units (ext coef/iwc): [(m^-1)/(g m^-3)]
- extice3(:, 16) = (/ &
-! band 16
- & 5.194013e-01_rb,3.215089e-01_rb,2.327917e-01_rb,1.824424e-01_rb,1.499977e-01_rb,&
- & 1.273492e-01_rb,1.106421e-01_rb,9.780982e-02_rb,8.764435e-02_rb,7.939266e-02_rb,&
- & 7.256081e-02_rb,6.681137e-02_rb,6.190600e-02_rb,5.767154e-02_rb,5.397915e-02_rb,&
- & 5.073102e-02_rb,4.785151e-02_rb,4.528125e-02_rb,4.297296e-02_rb,4.088853e-02_rb,&
- & 3.899690e-02_rb,3.727251e-02_rb,3.569411e-02_rb,3.424393e-02_rb,3.290694e-02_rb,&
- & 3.167040e-02_rb,3.052340e-02_rb,2.945654e-02_rb,2.846172e-02_rb,2.753188e-02_rb,&
- & 2.666085e-02_rb,2.584322e-02_rb,2.507423e-02_rb,2.434967e-02_rb,2.366579e-02_rb,&
- & 2.301926e-02_rb,2.240711e-02_rb,2.182666e-02_rb,2.127551e-02_rb,2.075150e-02_rb,&
- & 2.025267e-02_rb,1.977725e-02_rb,1.932364e-02_rb,1.889035e-02_rb,1.847607e-02_rb,&
- & 1.807956e-02_rb /)
- extice3(:, 17) = (/ &
-! band 17
- & 4.901155e-01_rb,3.065286e-01_rb,2.230800e-01_rb,1.753951e-01_rb,1.445402e-01_rb,&
- & 1.229417e-01_rb,1.069777e-01_rb,9.469760e-02_rb,8.495824e-02_rb,7.704501e-02_rb,&
- & 7.048834e-02_rb,6.496693e-02_rb,6.025353e-02_rb,5.618286e-02_rb,5.263186e-02_rb,&
- & 4.950698e-02_rb,4.673585e-02_rb,4.426164e-02_rb,4.203904e-02_rb,4.003153e-02_rb,&
- & 3.820932e-02_rb,3.654790e-02_rb,3.502688e-02_rb,3.362919e-02_rb,3.234041e-02_rb,&
- & 3.114829e-02_rb,3.004234e-02_rb,2.901356e-02_rb,2.805413e-02_rb,2.715727e-02_rb,&
- & 2.631705e-02_rb,2.552828e-02_rb,2.478637e-02_rb,2.408725e-02_rb,2.342734e-02_rb,&
- & 2.280343e-02_rb,2.221264e-02_rb,2.165242e-02_rb,2.112043e-02_rb,2.061461e-02_rb,&
- & 2.013308e-02_rb,1.967411e-02_rb,1.923616e-02_rb,1.881783e-02_rb,1.841781e-02_rb,&
- & 1.803494e-02_rb /)
- extice3(:, 18) = (/ &
-! band 18
- & 5.056264e-01_rb,3.160261e-01_rb,2.298442e-01_rb,1.805973e-01_rb,1.487318e-01_rb,&
- & 1.264258e-01_rb,1.099389e-01_rb,9.725656e-02_rb,8.719819e-02_rb,7.902576e-02_rb,&
- & 7.225433e-02_rb,6.655206e-02_rb,6.168427e-02_rb,5.748028e-02_rb,5.381296e-02_rb,&
- & 5.058572e-02_rb,4.772383e-02_rb,4.516857e-02_rb,4.287317e-02_rb,4.079990e-02_rb,&
- & 3.891801e-02_rb,3.720217e-02_rb,3.563133e-02_rb,3.418786e-02_rb,3.285686e-02_rb,&
- & 3.162569e-02_rb,3.048352e-02_rb,2.942104e-02_rb,2.843018e-02_rb,2.750395e-02_rb,&
- & 2.663621e-02_rb,2.582160e-02_rb,2.505539e-02_rb,2.433337e-02_rb,2.365185e-02_rb,&
- & 2.300750e-02_rb,2.239736e-02_rb,2.181878e-02_rb,2.126937e-02_rb,2.074699e-02_rb,&
- & 2.024968e-02_rb,1.977567e-02_rb,1.932338e-02_rb,1.889134e-02_rb,1.847823e-02_rb,&
- & 1.808281e-02_rb /)
- extice3(:, 19) = (/ &
-! band 19
- & 4.881605e-01_rb,3.055237e-01_rb,2.225070e-01_rb,1.750688e-01_rb,1.443736e-01_rb,&
- & 1.228869e-01_rb,1.070054e-01_rb,9.478893e-02_rb,8.509997e-02_rb,7.722769e-02_rb,&
- & 7.070495e-02_rb,6.521211e-02_rb,6.052311e-02_rb,5.647351e-02_rb,5.294088e-02_rb,&
- & 4.983217e-02_rb,4.707539e-02_rb,4.461398e-02_rb,4.240288e-02_rb,4.040575e-02_rb,&
- & 3.859298e-02_rb,3.694016e-02_rb,3.542701e-02_rb,3.403655e-02_rb,3.275444e-02_rb,&
- & 3.156849e-02_rb,3.046827e-02_rb,2.944481e-02_rb,2.849034e-02_rb,2.759812e-02_rb,&
- & 2.676226e-02_rb,2.597757e-02_rb,2.523949e-02_rb,2.454400e-02_rb,2.388750e-02_rb,&
- & 2.326682e-02_rb,2.267909e-02_rb,2.212176e-02_rb,2.159253e-02_rb,2.108933e-02_rb,&
- & 2.061028e-02_rb,2.015369e-02_rb,1.971801e-02_rb,1.930184e-02_rb,1.890389e-02_rb,&
- & 1.852300e-02_rb /)
- extice3(:, 20) = (/ &
-! band 20
- & 5.103703e-01_rb,3.188144e-01_rb,2.317435e-01_rb,1.819887e-01_rb,1.497944e-01_rb,&
- & 1.272584e-01_rb,1.106013e-01_rb,9.778822e-02_rb,8.762610e-02_rb,7.936938e-02_rb,&
- & 7.252809e-02_rb,6.676701e-02_rb,6.184901e-02_rb,5.760165e-02_rb,5.389651e-02_rb,&
- & 5.063598e-02_rb,4.774457e-02_rb,4.516295e-02_rb,4.284387e-02_rb,4.074922e-02_rb,&
- & 3.884792e-02_rb,3.711438e-02_rb,3.552734e-02_rb,3.406898e-02_rb,3.272425e-02_rb,&
- & 3.148038e-02_rb,3.032643e-02_rb,2.925299e-02_rb,2.825191e-02_rb,2.731612e-02_rb,&
- & 2.643943e-02_rb,2.561642e-02_rb,2.484230e-02_rb,2.411284e-02_rb,2.342429e-02_rb,&
- & 2.277329e-02_rb,2.215686e-02_rb,2.157231e-02_rb,2.101724e-02_rb,2.048946e-02_rb,&
- & 1.998702e-02_rb,1.950813e-02_rb,1.905118e-02_rb,1.861468e-02_rb,1.819730e-02_rb,&
- & 1.779781e-02_rb /)
- extice3(:, 21) = (/ &
-! band 21
- & 5.031161e-01_rb,3.144511e-01_rb,2.286942e-01_rb,1.796903e-01_rb,1.479819e-01_rb,&
- & 1.257860e-01_rb,1.093803e-01_rb,9.676059e-02_rb,8.675183e-02_rb,7.861971e-02_rb,&
- & 7.188168e-02_rb,6.620754e-02_rb,6.136376e-02_rb,5.718050e-02_rb,5.353127e-02_rb,&
- & 5.031995e-02_rb,4.747218e-02_rb,4.492952e-02_rb,4.264544e-02_rb,4.058240e-02_rb,&
- & 3.870979e-02_rb,3.700242e-02_rb,3.543933e-02_rb,3.400297e-02_rb,3.267854e-02_rb,&
- & 3.145345e-02_rb,3.031691e-02_rb,2.925967e-02_rb,2.827370e-02_rb,2.735203e-02_rb,&
- & 2.648858e-02_rb,2.567798e-02_rb,2.491555e-02_rb,2.419710e-02_rb,2.351893e-02_rb,&
- & 2.287776e-02_rb,2.227063e-02_rb,2.169491e-02_rb,2.114821e-02_rb,2.062840e-02_rb,&
- & 2.013354e-02_rb,1.966188e-02_rb,1.921182e-02_rb,1.878191e-02_rb,1.837083e-02_rb,&
- & 1.797737e-02_rb /)
- extice3(:, 22) = (/ &
-! band 22
- & 4.949453e-01_rb,3.095918e-01_rb,2.253402e-01_rb,1.771964e-01_rb,1.460446e-01_rb,&
- & 1.242383e-01_rb,1.081206e-01_rb,9.572235e-02_rb,8.588928e-02_rb,7.789990e-02_rb,&
- & 7.128013e-02_rb,6.570559e-02_rb,6.094684e-02_rb,5.683701e-02_rb,5.325183e-02_rb,&
- & 5.009688e-02_rb,4.729909e-02_rb,4.480106e-02_rb,4.255708e-02_rb,4.053025e-02_rb,&
- & 3.869051e-02_rb,3.701310e-02_rb,3.547745e-02_rb,3.406631e-02_rb,3.276512e-02_rb,&
- & 3.156153e-02_rb,3.044494e-02_rb,2.940626e-02_rb,2.843759e-02_rb,2.753211e-02_rb,&
- & 2.668381e-02_rb,2.588744e-02_rb,2.513839e-02_rb,2.443255e-02_rb,2.376629e-02_rb,&
- & 2.313637e-02_rb,2.253990e-02_rb,2.197428e-02_rb,2.143718e-02_rb,2.092649e-02_rb,&
- & 2.044032e-02_rb,1.997694e-02_rb,1.953478e-02_rb,1.911241e-02_rb,1.870855e-02_rb,&
- & 1.832199e-02_rb /)
- extice3(:, 23) = (/ &
-! band 23
- & 5.052816e-01_rb,3.157665e-01_rb,2.296233e-01_rb,1.803986e-01_rb,1.485473e-01_rb,&
- & 1.262514e-01_rb,1.097718e-01_rb,9.709524e-02_rb,8.704139e-02_rb,7.887264e-02_rb,&
- & 7.210424e-02_rb,6.640454e-02_rb,6.153894e-02_rb,5.733683e-02_rb,5.367116e-02_rb,&
- & 5.044537e-02_rb,4.758477e-02_rb,4.503066e-02_rb,4.273629e-02_rb,4.066395e-02_rb,&
- & 3.878291e-02_rb,3.706784e-02_rb,3.549771e-02_rb,3.405488e-02_rb,3.272448e-02_rb,&
- & 3.149387e-02_rb,3.035221e-02_rb,2.929020e-02_rb,2.829979e-02_rb,2.737397e-02_rb,&
- & 2.650663e-02_rb,2.569238e-02_rb,2.492651e-02_rb,2.420482e-02_rb,2.352361e-02_rb,&
- & 2.287954e-02_rb,2.226968e-02_rb,2.169136e-02_rb,2.114220e-02_rb,2.062005e-02_rb,&
- & 2.012296e-02_rb,1.964917e-02_rb,1.919709e-02_rb,1.876524e-02_rb,1.835231e-02_rb,&
- & 1.795707e-02_rb /)
- extice3(:, 24) = (/ &
-! band 24
- & 5.042067e-01_rb,3.151195e-01_rb,2.291708e-01_rb,1.800573e-01_rb,1.482779e-01_rb,&
- & 1.260324e-01_rb,1.095900e-01_rb,9.694202e-02_rb,8.691087e-02_rb,7.876056e-02_rb,&
- & 7.200745e-02_rb,6.632062e-02_rb,6.146600e-02_rb,5.727338e-02_rb,5.361599e-02_rb,&
- & 5.039749e-02_rb,4.754334e-02_rb,4.499500e-02_rb,4.270580e-02_rb,4.063815e-02_rb,&
- & 3.876135e-02_rb,3.705016e-02_rb,3.548357e-02_rb,3.404400e-02_rb,3.271661e-02_rb,&
- & 3.148877e-02_rb,3.034969e-02_rb,2.929008e-02_rb,2.830191e-02_rb,2.737818e-02_rb,&
- & 2.651279e-02_rb,2.570039e-02_rb,2.493624e-02_rb,2.421618e-02_rb,2.353650e-02_rb,&
- & 2.289390e-02_rb,2.228541e-02_rb,2.170840e-02_rb,2.116048e-02_rb,2.063950e-02_rb,&
- & 2.014354e-02_rb,1.967082e-02_rb,1.921975e-02_rb,1.878888e-02_rb,1.837688e-02_rb,&
- & 1.798254e-02_rb /)
- extice3(:, 25) = (/ &
-! band 25
- & 5.022507e-01_rb,3.139246e-01_rb,2.283218e-01_rb,1.794059e-01_rb,1.477544e-01_rb,&
- & 1.255984e-01_rb,1.092222e-01_rb,9.662516e-02_rb,8.663439e-02_rb,7.851688e-02_rb,&
- & 7.179095e-02_rb,6.612700e-02_rb,6.129193e-02_rb,5.711618e-02_rb,5.347351e-02_rb,&
- & 5.026796e-02_rb,4.742530e-02_rb,4.488721e-02_rb,4.260724e-02_rb,4.054790e-02_rb,&
- & 3.867866e-02_rb,3.697435e-02_rb,3.541407e-02_rb,3.398029e-02_rb,3.265824e-02_rb,&
- & 3.143535e-02_rb,3.030085e-02_rb,2.924551e-02_rb,2.826131e-02_rb,2.734130e-02_rb,&
- & 2.647939e-02_rb,2.567026e-02_rb,2.490919e-02_rb,2.419203e-02_rb,2.351509e-02_rb,&
- & 2.287507e-02_rb,2.226903e-02_rb,2.169434e-02_rb,2.114862e-02_rb,2.062975e-02_rb,&
- & 2.013578e-02_rb,1.966496e-02_rb,1.921571e-02_rb,1.878658e-02_rb,1.837623e-02_rb,&
- & 1.798348e-02_rb /)
- extice3(:, 26) = (/ &
-! band 26
- & 5.068316e-01_rb,3.166869e-01_rb,2.302576e-01_rb,1.808693e-01_rb,1.489122e-01_rb,&
- & 1.265423e-01_rb,1.100080e-01_rb,9.728926e-02_rb,8.720201e-02_rb,7.900612e-02_rb,&
- & 7.221524e-02_rb,6.649660e-02_rb,6.161484e-02_rb,5.739877e-02_rb,5.372093e-02_rb,&
- & 5.048442e-02_rb,4.761431e-02_rb,4.505172e-02_rb,4.274972e-02_rb,4.067050e-02_rb,&
- & 3.878321e-02_rb,3.706244e-02_rb,3.548710e-02_rb,3.403948e-02_rb,3.270466e-02_rb,&
- & 3.146995e-02_rb,3.032450e-02_rb,2.925897e-02_rb,2.826527e-02_rb,2.733638e-02_rb,&
- & 2.646615e-02_rb,2.564920e-02_rb,2.488078e-02_rb,2.415670e-02_rb,2.347322e-02_rb,&
- & 2.282702e-02_rb,2.221513e-02_rb,2.163489e-02_rb,2.108390e-02_rb,2.056002e-02_rb,&
- & 2.006128e-02_rb,1.958591e-02_rb,1.913232e-02_rb,1.869904e-02_rb,1.828474e-02_rb,&
- & 1.788819e-02_rb /)
- extice3(:, 27) = (/ &
-! band 27
- & 5.077707e-01_rb,3.172636e-01_rb,2.306695e-01_rb,1.811871e-01_rb,1.491691e-01_rb,&
- & 1.267565e-01_rb,1.101907e-01_rb,9.744773e-02_rb,8.734125e-02_rb,7.912973e-02_rb,&
- & 7.232591e-02_rb,6.659637e-02_rb,6.170530e-02_rb,5.748120e-02_rb,5.379634e-02_rb,&
- & 5.055367e-02_rb,4.767809e-02_rb,4.511061e-02_rb,4.280423e-02_rb,4.072104e-02_rb,&
- & 3.883015e-02_rb,3.710611e-02_rb,3.552776e-02_rb,3.407738e-02_rb,3.274002e-02_rb,&
- & 3.150296e-02_rb,3.035532e-02_rb,2.928776e-02_rb,2.829216e-02_rb,2.736150e-02_rb,&
- & 2.648961e-02_rb,2.567111e-02_rb,2.490123e-02_rb,2.417576e-02_rb,2.349098e-02_rb,&
- & 2.284354e-02_rb,2.223049e-02_rb,2.164914e-02_rb,2.109711e-02_rb,2.057222e-02_rb,&
- & 2.007253e-02_rb,1.959626e-02_rb,1.914181e-02_rb,1.870770e-02_rb,1.829261e-02_rb,&
- & 1.789531e-02_rb /)
- extice3(:, 28) = (/ &
-! band 28
- & 5.062281e-01_rb,3.163402e-01_rb,2.300275e-01_rb,1.807060e-01_rb,1.487921e-01_rb,&
- & 1.264523e-01_rb,1.099403e-01_rb,9.723879e-02_rb,8.716516e-02_rb,7.898034e-02_rb,&
- & 7.219863e-02_rb,6.648771e-02_rb,6.161254e-02_rb,5.740217e-02_rb,5.372929e-02_rb,&
- & 5.049716e-02_rb,4.763092e-02_rb,4.507179e-02_rb,4.277290e-02_rb,4.069649e-02_rb,&
- & 3.881175e-02_rb,3.709331e-02_rb,3.552008e-02_rb,3.407442e-02_rb,3.274141e-02_rb,&
- & 3.150837e-02_rb,3.036447e-02_rb,2.930037e-02_rb,2.830801e-02_rb,2.738037e-02_rb,&
- & 2.651132e-02_rb,2.569547e-02_rb,2.492810e-02_rb,2.420499e-02_rb,2.352243e-02_rb,&
- & 2.287710e-02_rb,2.226604e-02_rb,2.168658e-02_rb,2.113634e-02_rb,2.061316e-02_rb,&
- & 2.011510e-02_rb,1.964038e-02_rb,1.918740e-02_rb,1.875471e-02_rb,1.834096e-02_rb,&
- & 1.794495e-02_rb /)
- extice3(:, 29) = (/ &
-! band 29
- & 1.338834e-01_rb,1.924912e-01_rb,1.755523e-01_rb,1.534793e-01_rb,1.343937e-01_rb,&
- & 1.187883e-01_rb,1.060654e-01_rb,9.559106e-02_rb,8.685880e-02_rb,7.948698e-02_rb,&
- & 7.319086e-02_rb,6.775669e-02_rb,6.302215e-02_rb,5.886236e-02_rb,5.517996e-02_rb,&
- & 5.189810e-02_rb,4.895539e-02_rb,4.630225e-02_rb,4.389823e-02_rb,4.171002e-02_rb,&
- & 3.970998e-02_rb,3.787493e-02_rb,3.618537e-02_rb,3.462471e-02_rb,3.317880e-02_rb,&
- & 3.183547e-02_rb,3.058421e-02_rb,2.941590e-02_rb,2.832256e-02_rb,2.729724e-02_rb,&
- & 2.633377e-02_rb,2.542675e-02_rb,2.457136e-02_rb,2.376332e-02_rb,2.299882e-02_rb,&
- & 2.227443e-02_rb,2.158707e-02_rb,2.093400e-02_rb,2.031270e-02_rb,1.972091e-02_rb,&
- & 1.915659e-02_rb,1.861787e-02_rb,1.810304e-02_rb,1.761055e-02_rb,1.713899e-02_rb,&
- & 1.668704e-02_rb /)
-
-! single-scattering albedo: unitless
- ssaice3(:, 16) = (/ &
-! band 16
- & 6.749442e-01_rb,6.649947e-01_rb,6.565828e-01_rb,6.489928e-01_rb,6.420046e-01_rb,&
- & 6.355231e-01_rb,6.294964e-01_rb,6.238901e-01_rb,6.186783e-01_rb,6.138395e-01_rb,&
- & 6.093543e-01_rb,6.052049e-01_rb,6.013742e-01_rb,5.978457e-01_rb,5.946030e-01_rb,&
- & 5.916302e-01_rb,5.889115e-01_rb,5.864310e-01_rb,5.841731e-01_rb,5.821221e-01_rb,&
- & 5.802624e-01_rb,5.785785e-01_rb,5.770549e-01_rb,5.756759e-01_rb,5.744262e-01_rb,&
- & 5.732901e-01_rb,5.722524e-01_rb,5.712974e-01_rb,5.704097e-01_rb,5.695739e-01_rb,&
- & 5.687747e-01_rb,5.679964e-01_rb,5.672238e-01_rb,5.664415e-01_rb,5.656340e-01_rb,&
- & 5.647860e-01_rb,5.638821e-01_rb,5.629070e-01_rb,5.618452e-01_rb,5.606815e-01_rb,&
- & 5.594006e-01_rb,5.579870e-01_rb,5.564255e-01_rb,5.547008e-01_rb,5.527976e-01_rb,&
- & 5.507005e-01_rb /)
- ssaice3(:, 17) = (/ &
-! band 17
- & 7.628550e-01_rb,7.567297e-01_rb,7.508463e-01_rb,7.451972e-01_rb,7.397745e-01_rb,&
- & 7.345705e-01_rb,7.295775e-01_rb,7.247881e-01_rb,7.201945e-01_rb,7.157894e-01_rb,&
- & 7.115652e-01_rb,7.075145e-01_rb,7.036300e-01_rb,6.999044e-01_rb,6.963304e-01_rb,&
- & 6.929007e-01_rb,6.896083e-01_rb,6.864460e-01_rb,6.834067e-01_rb,6.804833e-01_rb,&
- & 6.776690e-01_rb,6.749567e-01_rb,6.723397e-01_rb,6.698109e-01_rb,6.673637e-01_rb,&
- & 6.649913e-01_rb,6.626870e-01_rb,6.604441e-01_rb,6.582561e-01_rb,6.561163e-01_rb,&
- & 6.540182e-01_rb,6.519554e-01_rb,6.499215e-01_rb,6.479099e-01_rb,6.459145e-01_rb,&
- & 6.439289e-01_rb,6.419468e-01_rb,6.399621e-01_rb,6.379686e-01_rb,6.359601e-01_rb,&
- & 6.339306e-01_rb,6.318740e-01_rb,6.297845e-01_rb,6.276559e-01_rb,6.254825e-01_rb,&
- & 6.232583e-01_rb /)
- ssaice3(:, 18) = (/ &
-! band 18
- & 9.924147e-01_rb,9.882792e-01_rb,9.842257e-01_rb,9.802522e-01_rb,9.763566e-01_rb,&
- & 9.725367e-01_rb,9.687905e-01_rb,9.651157e-01_rb,9.615104e-01_rb,9.579725e-01_rb,&
- & 9.544997e-01_rb,9.510901e-01_rb,9.477416e-01_rb,9.444520e-01_rb,9.412194e-01_rb,&
- & 9.380415e-01_rb,9.349165e-01_rb,9.318421e-01_rb,9.288164e-01_rb,9.258373e-01_rb,&
- & 9.229027e-01_rb,9.200106e-01_rb,9.171589e-01_rb,9.143457e-01_rb,9.115688e-01_rb,&
- & 9.088263e-01_rb,9.061161e-01_rb,9.034362e-01_rb,9.007846e-01_rb,8.981592e-01_rb,&
- & 8.955581e-01_rb,8.929792e-01_rb,8.904206e-01_rb,8.878803e-01_rb,8.853562e-01_rb,&
- & 8.828464e-01_rb,8.803488e-01_rb,8.778616e-01_rb,8.753827e-01_rb,8.729102e-01_rb,&
- & 8.704421e-01_rb,8.679764e-01_rb,8.655112e-01_rb,8.630445e-01_rb,8.605744e-01_rb,&
- & 8.580989e-01_rb /)
- ssaice3(:, 19) = (/ &
-! band 19
- & 9.629413e-01_rb,9.517182e-01_rb,9.409209e-01_rb,9.305366e-01_rb,9.205529e-01_rb,&
- & 9.109569e-01_rb,9.017362e-01_rb,8.928780e-01_rb,8.843699e-01_rb,8.761992e-01_rb,&
- & 8.683536e-01_rb,8.608204e-01_rb,8.535873e-01_rb,8.466417e-01_rb,8.399712e-01_rb,&
- & 8.335635e-01_rb,8.274062e-01_rb,8.214868e-01_rb,8.157932e-01_rb,8.103129e-01_rb,&
- & 8.050336e-01_rb,7.999432e-01_rb,7.950294e-01_rb,7.902798e-01_rb,7.856825e-01_rb,&
- & 7.812250e-01_rb,7.768954e-01_rb,7.726815e-01_rb,7.685711e-01_rb,7.645522e-01_rb,&
- & 7.606126e-01_rb,7.567404e-01_rb,7.529234e-01_rb,7.491498e-01_rb,7.454074e-01_rb,&
- & 7.416844e-01_rb,7.379688e-01_rb,7.342485e-01_rb,7.305118e-01_rb,7.267468e-01_rb,&
- & 7.229415e-01_rb,7.190841e-01_rb,7.151628e-01_rb,7.111657e-01_rb,7.070811e-01_rb,&
- & 7.028972e-01_rb /)
- ssaice3(:, 20) = (/ &
-! band 20
- & 9.942270e-01_rb,9.909206e-01_rb,9.876775e-01_rb,9.844960e-01_rb,9.813746e-01_rb,&
- & 9.783114e-01_rb,9.753049e-01_rb,9.723535e-01_rb,9.694553e-01_rb,9.666088e-01_rb,&
- & 9.638123e-01_rb,9.610641e-01_rb,9.583626e-01_rb,9.557060e-01_rb,9.530928e-01_rb,&
- & 9.505211e-01_rb,9.479895e-01_rb,9.454961e-01_rb,9.430393e-01_rb,9.406174e-01_rb,&
- & 9.382288e-01_rb,9.358717e-01_rb,9.335446e-01_rb,9.312456e-01_rb,9.289731e-01_rb,&
- & 9.267255e-01_rb,9.245010e-01_rb,9.222980e-01_rb,9.201147e-01_rb,9.179496e-01_rb,&
- & 9.158008e-01_rb,9.136667e-01_rb,9.115457e-01_rb,9.094359e-01_rb,9.073358e-01_rb,&
- & 9.052436e-01_rb,9.031577e-01_rb,9.010763e-01_rb,8.989977e-01_rb,8.969203e-01_rb,&
- & 8.948423e-01_rb,8.927620e-01_rb,8.906778e-01_rb,8.885879e-01_rb,8.864907e-01_rb,&
- & 8.843843e-01_rb /)
- ssaice3(:, 21) = (/ &
-! band 21
- & 9.934014e-01_rb,9.899331e-01_rb,9.865537e-01_rb,9.832610e-01_rb,9.800523e-01_rb,&
- & 9.769254e-01_rb,9.738777e-01_rb,9.709069e-01_rb,9.680106e-01_rb,9.651862e-01_rb,&
- & 9.624315e-01_rb,9.597439e-01_rb,9.571212e-01_rb,9.545608e-01_rb,9.520605e-01_rb,&
- & 9.496177e-01_rb,9.472301e-01_rb,9.448954e-01_rb,9.426111e-01_rb,9.403749e-01_rb,&
- & 9.381843e-01_rb,9.360370e-01_rb,9.339307e-01_rb,9.318629e-01_rb,9.298313e-01_rb,&
- & 9.278336e-01_rb,9.258673e-01_rb,9.239302e-01_rb,9.220198e-01_rb,9.201338e-01_rb,&
- & 9.182700e-01_rb,9.164258e-01_rb,9.145991e-01_rb,9.127874e-01_rb,9.109884e-01_rb,&
- & 9.091999e-01_rb,9.074194e-01_rb,9.056447e-01_rb,9.038735e-01_rb,9.021033e-01_rb,&
- & 9.003320e-01_rb,8.985572e-01_rb,8.967766e-01_rb,8.949879e-01_rb,8.931888e-01_rb,&
- & 8.913770e-01_rb /)
- ssaice3(:, 22) = (/ &
-! band 22
- & 9.994833e-01_rb,9.992055e-01_rb,9.989278e-01_rb,9.986500e-01_rb,9.983724e-01_rb,&
- & 9.980947e-01_rb,9.978172e-01_rb,9.975397e-01_rb,9.972623e-01_rb,9.969849e-01_rb,&
- & 9.967077e-01_rb,9.964305e-01_rb,9.961535e-01_rb,9.958765e-01_rb,9.955997e-01_rb,&
- & 9.953230e-01_rb,9.950464e-01_rb,9.947699e-01_rb,9.944936e-01_rb,9.942174e-01_rb,&
- & 9.939414e-01_rb,9.936656e-01_rb,9.933899e-01_rb,9.931144e-01_rb,9.928390e-01_rb,&
- & 9.925639e-01_rb,9.922889e-01_rb,9.920141e-01_rb,9.917396e-01_rb,9.914652e-01_rb,&
- & 9.911911e-01_rb,9.909171e-01_rb,9.906434e-01_rb,9.903700e-01_rb,9.900967e-01_rb,&
- & 9.898237e-01_rb,9.895510e-01_rb,9.892784e-01_rb,9.890062e-01_rb,9.887342e-01_rb,&
- & 9.884625e-01_rb,9.881911e-01_rb,9.879199e-01_rb,9.876490e-01_rb,9.873784e-01_rb,&
- & 9.871081e-01_rb /)
- ssaice3(:, 23) = (/ &
-! band 23
- & 9.999343e-01_rb,9.998917e-01_rb,9.998492e-01_rb,9.998067e-01_rb,9.997642e-01_rb,&
- & 9.997218e-01_rb,9.996795e-01_rb,9.996372e-01_rb,9.995949e-01_rb,9.995528e-01_rb,&
- & 9.995106e-01_rb,9.994686e-01_rb,9.994265e-01_rb,9.993845e-01_rb,9.993426e-01_rb,&
- & 9.993007e-01_rb,9.992589e-01_rb,9.992171e-01_rb,9.991754e-01_rb,9.991337e-01_rb,&
- & 9.990921e-01_rb,9.990505e-01_rb,9.990089e-01_rb,9.989674e-01_rb,9.989260e-01_rb,&
- & 9.988846e-01_rb,9.988432e-01_rb,9.988019e-01_rb,9.987606e-01_rb,9.987194e-01_rb,&
- & 9.986782e-01_rb,9.986370e-01_rb,9.985959e-01_rb,9.985549e-01_rb,9.985139e-01_rb,&
- & 9.984729e-01_rb,9.984319e-01_rb,9.983910e-01_rb,9.983502e-01_rb,9.983094e-01_rb,&
- & 9.982686e-01_rb,9.982279e-01_rb,9.981872e-01_rb,9.981465e-01_rb,9.981059e-01_rb,&
- & 9.980653e-01_rb /)
- ssaice3(:, 24) = (/ &
-! band 24
- & 9.999978e-01_rb,9.999965e-01_rb,9.999952e-01_rb,9.999939e-01_rb,9.999926e-01_rb,&
- & 9.999913e-01_rb,9.999900e-01_rb,9.999887e-01_rb,9.999873e-01_rb,9.999860e-01_rb,&
- & 9.999847e-01_rb,9.999834e-01_rb,9.999821e-01_rb,9.999808e-01_rb,9.999795e-01_rb,&
- & 9.999782e-01_rb,9.999769e-01_rb,9.999756e-01_rb,9.999743e-01_rb,9.999730e-01_rb,&
- & 9.999717e-01_rb,9.999704e-01_rb,9.999691e-01_rb,9.999678e-01_rb,9.999665e-01_rb,&
- & 9.999652e-01_rb,9.999639e-01_rb,9.999626e-01_rb,9.999613e-01_rb,9.999600e-01_rb,&
- & 9.999587e-01_rb,9.999574e-01_rb,9.999561e-01_rb,9.999548e-01_rb,9.999535e-01_rb,&
- & 9.999522e-01_rb,9.999509e-01_rb,9.999496e-01_rb,9.999483e-01_rb,9.999470e-01_rb,&
- & 9.999457e-01_rb,9.999444e-01_rb,9.999431e-01_rb,9.999418e-01_rb,9.999405e-01_rb,&
- & 9.999392e-01_rb /)
- ssaice3(:, 25) = (/ &
-! band 25
- & 9.999994e-01_rb,9.999993e-01_rb,9.999991e-01_rb,9.999990e-01_rb,9.999989e-01_rb,&
- & 9.999987e-01_rb,9.999986e-01_rb,9.999984e-01_rb,9.999983e-01_rb,9.999982e-01_rb,&
- & 9.999980e-01_rb,9.999979e-01_rb,9.999977e-01_rb,9.999976e-01_rb,9.999975e-01_rb,&
- & 9.999973e-01_rb,9.999972e-01_rb,9.999970e-01_rb,9.999969e-01_rb,9.999967e-01_rb,&
- & 9.999966e-01_rb,9.999965e-01_rb,9.999963e-01_rb,9.999962e-01_rb,9.999960e-01_rb,&
- & 9.999959e-01_rb,9.999957e-01_rb,9.999956e-01_rb,9.999954e-01_rb,9.999953e-01_rb,&
- & 9.999952e-01_rb,9.999950e-01_rb,9.999949e-01_rb,9.999947e-01_rb,9.999946e-01_rb,&
- & 9.999944e-01_rb,9.999943e-01_rb,9.999941e-01_rb,9.999940e-01_rb,9.999939e-01_rb,&
- & 9.999937e-01_rb,9.999936e-01_rb,9.999934e-01_rb,9.999933e-01_rb,9.999931e-01_rb,&
- & 9.999930e-01_rb /)
- ssaice3(:, 26) = (/ &
-! band 26
- & 9.999997e-01_rb,9.999995e-01_rb,9.999992e-01_rb,9.999990e-01_rb,9.999987e-01_rb,&
- & 9.999985e-01_rb,9.999983e-01_rb,9.999980e-01_rb,9.999978e-01_rb,9.999976e-01_rb,&
- & 9.999973e-01_rb,9.999971e-01_rb,9.999969e-01_rb,9.999967e-01_rb,9.999965e-01_rb,&
- & 9.999963e-01_rb,9.999960e-01_rb,9.999958e-01_rb,9.999956e-01_rb,9.999954e-01_rb,&
- & 9.999952e-01_rb,9.999950e-01_rb,9.999948e-01_rb,9.999946e-01_rb,9.999944e-01_rb,&
- & 9.999942e-01_rb,9.999939e-01_rb,9.999937e-01_rb,9.999935e-01_rb,9.999933e-01_rb,&
- & 9.999931e-01_rb,9.999929e-01_rb,9.999927e-01_rb,9.999925e-01_rb,9.999923e-01_rb,&
- & 9.999920e-01_rb,9.999918e-01_rb,9.999916e-01_rb,9.999914e-01_rb,9.999911e-01_rb,&
- & 9.999909e-01_rb,9.999907e-01_rb,9.999905e-01_rb,9.999902e-01_rb,9.999900e-01_rb,&
- & 9.999897e-01_rb /)
- ssaice3(:, 27) = (/ &
-! band 27
- & 9.999991e-01_rb,9.999985e-01_rb,9.999980e-01_rb,9.999974e-01_rb,9.999968e-01_rb,&
- & 9.999963e-01_rb,9.999957e-01_rb,9.999951e-01_rb,9.999946e-01_rb,9.999940e-01_rb,&
- & 9.999934e-01_rb,9.999929e-01_rb,9.999923e-01_rb,9.999918e-01_rb,9.999912e-01_rb,&
- & 9.999907e-01_rb,9.999901e-01_rb,9.999896e-01_rb,9.999891e-01_rb,9.999885e-01_rb,&
- & 9.999880e-01_rb,9.999874e-01_rb,9.999869e-01_rb,9.999863e-01_rb,9.999858e-01_rb,&
- & 9.999853e-01_rb,9.999847e-01_rb,9.999842e-01_rb,9.999836e-01_rb,9.999831e-01_rb,&
- & 9.999826e-01_rb,9.999820e-01_rb,9.999815e-01_rb,9.999809e-01_rb,9.999804e-01_rb,&
- & 9.999798e-01_rb,9.999793e-01_rb,9.999787e-01_rb,9.999782e-01_rb,9.999776e-01_rb,&
- & 9.999770e-01_rb,9.999765e-01_rb,9.999759e-01_rb,9.999754e-01_rb,9.999748e-01_rb,&
- & 9.999742e-01_rb /)
- ssaice3(:, 28) = (/ &
-! band 28
- & 9.999975e-01_rb,9.999961e-01_rb,9.999946e-01_rb,9.999931e-01_rb,9.999917e-01_rb,&
- & 9.999903e-01_rb,9.999888e-01_rb,9.999874e-01_rb,9.999859e-01_rb,9.999845e-01_rb,&
- & 9.999831e-01_rb,9.999816e-01_rb,9.999802e-01_rb,9.999788e-01_rb,9.999774e-01_rb,&
- & 9.999759e-01_rb,9.999745e-01_rb,9.999731e-01_rb,9.999717e-01_rb,9.999702e-01_rb,&
- & 9.999688e-01_rb,9.999674e-01_rb,9.999660e-01_rb,9.999646e-01_rb,9.999631e-01_rb,&
- & 9.999617e-01_rb,9.999603e-01_rb,9.999589e-01_rb,9.999574e-01_rb,9.999560e-01_rb,&
- & 9.999546e-01_rb,9.999532e-01_rb,9.999517e-01_rb,9.999503e-01_rb,9.999489e-01_rb,&
- & 9.999474e-01_rb,9.999460e-01_rb,9.999446e-01_rb,9.999431e-01_rb,9.999417e-01_rb,&
- & 9.999403e-01_rb,9.999388e-01_rb,9.999374e-01_rb,9.999359e-01_rb,9.999345e-01_rb,&
- & 9.999330e-01_rb /)
- ssaice3(:, 29) = (/ &
-! band 29
- & 4.526500e-01_rb,5.287890e-01_rb,5.410487e-01_rb,5.459865e-01_rb,5.485149e-01_rb,&
- & 5.498914e-01_rb,5.505895e-01_rb,5.508310e-01_rb,5.507364e-01_rb,5.503793e-01_rb,&
- & 5.498090e-01_rb,5.490612e-01_rb,5.481637e-01_rb,5.471395e-01_rb,5.460083e-01_rb,&
- & 5.447878e-01_rb,5.434946e-01_rb,5.421442e-01_rb,5.407514e-01_rb,5.393309e-01_rb,&
- & 5.378970e-01_rb,5.364641e-01_rb,5.350464e-01_rb,5.336582e-01_rb,5.323140e-01_rb,&
- & 5.310283e-01_rb,5.298158e-01_rb,5.286914e-01_rb,5.276704e-01_rb,5.267680e-01_rb,&
- & 5.260000e-01_rb,5.253823e-01_rb,5.249311e-01_rb,5.246629e-01_rb,5.245946e-01_rb,&
- & 5.247434e-01_rb,5.251268e-01_rb,5.257626e-01_rb,5.266693e-01_rb,5.278653e-01_rb,&
- & 5.293698e-01_rb,5.312022e-01_rb,5.333823e-01_rb,5.359305e-01_rb,5.388676e-01_rb,&
- & 5.422146e-01_rb /)
-
-! asymmetry factor: unitless
- asyice3(:, 16) = (/ &
-! band 16
- & 8.340752e-01_rb,8.435170e-01_rb,8.517487e-01_rb,8.592064e-01_rb,8.660387e-01_rb,&
- & 8.723204e-01_rb,8.780997e-01_rb,8.834137e-01_rb,8.882934e-01_rb,8.927662e-01_rb,&
- & 8.968577e-01_rb,9.005914e-01_rb,9.039899e-01_rb,9.070745e-01_rb,9.098659e-01_rb,&
- & 9.123836e-01_rb,9.146466e-01_rb,9.166734e-01_rb,9.184817e-01_rb,9.200886e-01_rb,&
- & 9.215109e-01_rb,9.227648e-01_rb,9.238661e-01_rb,9.248304e-01_rb,9.256727e-01_rb,&
- & 9.264078e-01_rb,9.270505e-01_rb,9.276150e-01_rb,9.281156e-01_rb,9.285662e-01_rb,&
- & 9.289806e-01_rb,9.293726e-01_rb,9.297557e-01_rb,9.301435e-01_rb,9.305491e-01_rb,&
- & 9.309859e-01_rb,9.314671e-01_rb,9.320055e-01_rb,9.326140e-01_rb,9.333053e-01_rb,&
- & 9.340919e-01_rb,9.349861e-01_rb,9.360000e-01_rb,9.371451e-01_rb,9.384329e-01_rb,&
- & 9.398744e-01_rb /)
- asyice3(:, 17) = (/ &
-! band 17
- & 8.728160e-01_rb,8.777333e-01_rb,8.823754e-01_rb,8.867535e-01_rb,8.908785e-01_rb,&
- & 8.947611e-01_rb,8.984118e-01_rb,9.018408e-01_rb,9.050582e-01_rb,9.080739e-01_rb,&
- & 9.108976e-01_rb,9.135388e-01_rb,9.160068e-01_rb,9.183106e-01_rb,9.204595e-01_rb,&
- & 9.224620e-01_rb,9.243271e-01_rb,9.260632e-01_rb,9.276788e-01_rb,9.291822e-01_rb,&
- & 9.305817e-01_rb,9.318853e-01_rb,9.331012e-01_rb,9.342372e-01_rb,9.353013e-01_rb,&
- & 9.363013e-01_rb,9.372450e-01_rb,9.381400e-01_rb,9.389939e-01_rb,9.398145e-01_rb,&
- & 9.406092e-01_rb,9.413856e-01_rb,9.421511e-01_rb,9.429131e-01_rb,9.436790e-01_rb,&
- & 9.444561e-01_rb,9.452517e-01_rb,9.460729e-01_rb,9.469270e-01_rb,9.478209e-01_rb,&
- & 9.487617e-01_rb,9.497562e-01_rb,9.508112e-01_rb,9.519335e-01_rb,9.531294e-01_rb,&
- & 9.544055e-01_rb /)
- asyice3(:, 18) = (/ &
-! band 18
- & 7.897566e-01_rb,7.948704e-01_rb,7.998041e-01_rb,8.045623e-01_rb,8.091495e-01_rb,&
- & 8.135702e-01_rb,8.178290e-01_rb,8.219305e-01_rb,8.258790e-01_rb,8.296792e-01_rb,&
- & 8.333355e-01_rb,8.368524e-01_rb,8.402343e-01_rb,8.434856e-01_rb,8.466108e-01_rb,&
- & 8.496143e-01_rb,8.525004e-01_rb,8.552737e-01_rb,8.579384e-01_rb,8.604990e-01_rb,&
- & 8.629597e-01_rb,8.653250e-01_rb,8.675992e-01_rb,8.697867e-01_rb,8.718916e-01_rb,&
- & 8.739185e-01_rb,8.758715e-01_rb,8.777551e-01_rb,8.795734e-01_rb,8.813308e-01_rb,&
- & 8.830315e-01_rb,8.846799e-01_rb,8.862802e-01_rb,8.878366e-01_rb,8.893534e-01_rb,&
- & 8.908350e-01_rb,8.922854e-01_rb,8.937090e-01_rb,8.951099e-01_rb,8.964925e-01_rb,&
- & 8.978609e-01_rb,8.992192e-01_rb,9.005718e-01_rb,9.019229e-01_rb,9.032765e-01_rb,&
- & 9.046369e-01_rb /)
- asyice3(:, 19) = (/ &
-! band 19
- & 7.812615e-01_rb,7.887764e-01_rb,7.959664e-01_rb,8.028413e-01_rb,8.094109e-01_rb,&
- & 8.156849e-01_rb,8.216730e-01_rb,8.273846e-01_rb,8.328294e-01_rb,8.380166e-01_rb,&
- & 8.429556e-01_rb,8.476556e-01_rb,8.521258e-01_rb,8.563753e-01_rb,8.604131e-01_rb,&
- & 8.642481e-01_rb,8.678893e-01_rb,8.713455e-01_rb,8.746254e-01_rb,8.777378e-01_rb,&
- & 8.806914e-01_rb,8.834948e-01_rb,8.861566e-01_rb,8.886854e-01_rb,8.910897e-01_rb,&
- & 8.933779e-01_rb,8.955586e-01_rb,8.976402e-01_rb,8.996311e-01_rb,9.015398e-01_rb,&
- & 9.033745e-01_rb,9.051436e-01_rb,9.068555e-01_rb,9.085185e-01_rb,9.101410e-01_rb,&
- & 9.117311e-01_rb,9.132972e-01_rb,9.148476e-01_rb,9.163905e-01_rb,9.179340e-01_rb,&
- & 9.194864e-01_rb,9.210559e-01_rb,9.226505e-01_rb,9.242784e-01_rb,9.259476e-01_rb,&
- & 9.276661e-01_rb /)
- asyice3(:, 20) = (/ &
-! band 20
- & 7.640720e-01_rb,7.691119e-01_rb,7.739941e-01_rb,7.787222e-01_rb,7.832998e-01_rb,&
- & 7.877304e-01_rb,7.920177e-01_rb,7.961652e-01_rb,8.001765e-01_rb,8.040551e-01_rb,&
- & 8.078044e-01_rb,8.114280e-01_rb,8.149294e-01_rb,8.183119e-01_rb,8.215791e-01_rb,&
- & 8.247344e-01_rb,8.277812e-01_rb,8.307229e-01_rb,8.335629e-01_rb,8.363046e-01_rb,&
- & 8.389514e-01_rb,8.415067e-01_rb,8.439738e-01_rb,8.463560e-01_rb,8.486568e-01_rb,&
- & 8.508795e-01_rb,8.530274e-01_rb,8.551039e-01_rb,8.571122e-01_rb,8.590558e-01_rb,&
- & 8.609378e-01_rb,8.627618e-01_rb,8.645309e-01_rb,8.662485e-01_rb,8.679178e-01_rb,&
- & 8.695423e-01_rb,8.711251e-01_rb,8.726697e-01_rb,8.741792e-01_rb,8.756571e-01_rb,&
- & 8.771065e-01_rb,8.785307e-01_rb,8.799331e-01_rb,8.813169e-01_rb,8.826854e-01_rb,&
- & 8.840419e-01_rb /)
- asyice3(:, 21) = (/ &
-! band 21
- & 7.602598e-01_rb,7.651572e-01_rb,7.699014e-01_rb,7.744962e-01_rb,7.789452e-01_rb,&
- & 7.832522e-01_rb,7.874205e-01_rb,7.914538e-01_rb,7.953555e-01_rb,7.991290e-01_rb,&
- & 8.027777e-01_rb,8.063049e-01_rb,8.097140e-01_rb,8.130081e-01_rb,8.161906e-01_rb,&
- & 8.192645e-01_rb,8.222331e-01_rb,8.250993e-01_rb,8.278664e-01_rb,8.305374e-01_rb,&
- & 8.331153e-01_rb,8.356030e-01_rb,8.380037e-01_rb,8.403201e-01_rb,8.425553e-01_rb,&
- & 8.447121e-01_rb,8.467935e-01_rb,8.488022e-01_rb,8.507412e-01_rb,8.526132e-01_rb,&
- & 8.544210e-01_rb,8.561675e-01_rb,8.578554e-01_rb,8.594875e-01_rb,8.610665e-01_rb,&
- & 8.625951e-01_rb,8.640760e-01_rb,8.655119e-01_rb,8.669055e-01_rb,8.682594e-01_rb,&
- & 8.695763e-01_rb,8.708587e-01_rb,8.721094e-01_rb,8.733308e-01_rb,8.745255e-01_rb,&
- & 8.756961e-01_rb /)
- asyice3(:, 22) = (/ &
-! band 22
- & 7.568957e-01_rb,7.606995e-01_rb,7.644072e-01_rb,7.680204e-01_rb,7.715402e-01_rb,&
- & 7.749682e-01_rb,7.783057e-01_rb,7.815541e-01_rb,7.847148e-01_rb,7.877892e-01_rb,&
- & 7.907786e-01_rb,7.936846e-01_rb,7.965084e-01_rb,7.992515e-01_rb,8.019153e-01_rb,&
- & 8.045011e-01_rb,8.070103e-01_rb,8.094444e-01_rb,8.118048e-01_rb,8.140927e-01_rb,&
- & 8.163097e-01_rb,8.184571e-01_rb,8.205364e-01_rb,8.225488e-01_rb,8.244958e-01_rb,&
- & 8.263789e-01_rb,8.281993e-01_rb,8.299586e-01_rb,8.316580e-01_rb,8.332991e-01_rb,&
- & 8.348831e-01_rb,8.364115e-01_rb,8.378857e-01_rb,8.393071e-01_rb,8.406770e-01_rb,&
- & 8.419969e-01_rb,8.432682e-01_rb,8.444923e-01_rb,8.456706e-01_rb,8.468044e-01_rb,&
- & 8.478952e-01_rb,8.489444e-01_rb,8.499533e-01_rb,8.509234e-01_rb,8.518561e-01_rb,&
- & 8.527528e-01_rb /)
- asyice3(:, 23) = (/ &
-! band 23
- & 7.575066e-01_rb,7.606912e-01_rb,7.638236e-01_rb,7.669035e-01_rb,7.699306e-01_rb,&
- & 7.729046e-01_rb,7.758254e-01_rb,7.786926e-01_rb,7.815060e-01_rb,7.842654e-01_rb,&
- & 7.869705e-01_rb,7.896211e-01_rb,7.922168e-01_rb,7.947574e-01_rb,7.972428e-01_rb,&
- & 7.996726e-01_rb,8.020466e-01_rb,8.043646e-01_rb,8.066262e-01_rb,8.088313e-01_rb,&
- & 8.109796e-01_rb,8.130709e-01_rb,8.151049e-01_rb,8.170814e-01_rb,8.190001e-01_rb,&
- & 8.208608e-01_rb,8.226632e-01_rb,8.244071e-01_rb,8.260924e-01_rb,8.277186e-01_rb,&
- & 8.292856e-01_rb,8.307932e-01_rb,8.322411e-01_rb,8.336291e-01_rb,8.349570e-01_rb,&
- & 8.362244e-01_rb,8.374312e-01_rb,8.385772e-01_rb,8.396621e-01_rb,8.406856e-01_rb,&
- & 8.416476e-01_rb,8.425479e-01_rb,8.433861e-01_rb,8.441620e-01_rb,8.448755e-01_rb,&
- & 8.455263e-01_rb /)
- asyice3(:, 24) = (/ &
-! band 24
- & 7.568829e-01_rb,7.597947e-01_rb,7.626745e-01_rb,7.655212e-01_rb,7.683337e-01_rb,&
- & 7.711111e-01_rb,7.738523e-01_rb,7.765565e-01_rb,7.792225e-01_rb,7.818494e-01_rb,&
- & 7.844362e-01_rb,7.869819e-01_rb,7.894854e-01_rb,7.919459e-01_rb,7.943623e-01_rb,&
- & 7.967337e-01_rb,7.990590e-01_rb,8.013373e-01_rb,8.035676e-01_rb,8.057488e-01_rb,&
- & 8.078802e-01_rb,8.099605e-01_rb,8.119890e-01_rb,8.139645e-01_rb,8.158862e-01_rb,&
- & 8.177530e-01_rb,8.195641e-01_rb,8.213183e-01_rb,8.230149e-01_rb,8.246527e-01_rb,&
- & 8.262308e-01_rb,8.277483e-01_rb,8.292042e-01_rb,8.305976e-01_rb,8.319275e-01_rb,&
- & 8.331929e-01_rb,8.343929e-01_rb,8.355265e-01_rb,8.365928e-01_rb,8.375909e-01_rb,&
- & 8.385197e-01_rb,8.393784e-01_rb,8.401659e-01_rb,8.408815e-01_rb,8.415240e-01_rb,&
- & 8.420926e-01_rb /)
- asyice3(:, 25) = (/ &
-! band 25
- & 7.548616e-01_rb,7.575454e-01_rb,7.602153e-01_rb,7.628696e-01_rb,7.655067e-01_rb,&
- & 7.681249e-01_rb,7.707225e-01_rb,7.732978e-01_rb,7.758492e-01_rb,7.783750e-01_rb,&
- & 7.808735e-01_rb,7.833430e-01_rb,7.857819e-01_rb,7.881886e-01_rb,7.905612e-01_rb,&
- & 7.928983e-01_rb,7.951980e-01_rb,7.974588e-01_rb,7.996789e-01_rb,8.018567e-01_rb,&
- & 8.039905e-01_rb,8.060787e-01_rb,8.081196e-01_rb,8.101115e-01_rb,8.120527e-01_rb,&
- & 8.139416e-01_rb,8.157764e-01_rb,8.175557e-01_rb,8.192776e-01_rb,8.209405e-01_rb,&
- & 8.225427e-01_rb,8.240826e-01_rb,8.255585e-01_rb,8.269688e-01_rb,8.283117e-01_rb,&
- & 8.295856e-01_rb,8.307889e-01_rb,8.319198e-01_rb,8.329767e-01_rb,8.339579e-01_rb,&
- & 8.348619e-01_rb,8.356868e-01_rb,8.364311e-01_rb,8.370930e-01_rb,8.376710e-01_rb,&
- & 8.381633e-01_rb /)
- asyice3(:, 26) = (/ &
-! band 26
- & 7.491854e-01_rb,7.518523e-01_rb,7.545089e-01_rb,7.571534e-01_rb,7.597839e-01_rb,&
- & 7.623987e-01_rb,7.649959e-01_rb,7.675737e-01_rb,7.701303e-01_rb,7.726639e-01_rb,&
- & 7.751727e-01_rb,7.776548e-01_rb,7.801084e-01_rb,7.825318e-01_rb,7.849230e-01_rb,&
- & 7.872804e-01_rb,7.896020e-01_rb,7.918862e-01_rb,7.941309e-01_rb,7.963345e-01_rb,&
- & 7.984951e-01_rb,8.006109e-01_rb,8.026802e-01_rb,8.047009e-01_rb,8.066715e-01_rb,&
- & 8.085900e-01_rb,8.104546e-01_rb,8.122636e-01_rb,8.140150e-01_rb,8.157072e-01_rb,&
- & 8.173382e-01_rb,8.189063e-01_rb,8.204096e-01_rb,8.218464e-01_rb,8.232148e-01_rb,&
- & 8.245130e-01_rb,8.257391e-01_rb,8.268915e-01_rb,8.279682e-01_rb,8.289675e-01_rb,&
- & 8.298875e-01_rb,8.307264e-01_rb,8.314824e-01_rb,8.321537e-01_rb,8.327385e-01_rb,&
- & 8.332350e-01_rb /)
- asyice3(:, 27) = (/ &
-! band 27
- & 7.397086e-01_rb,7.424069e-01_rb,7.450955e-01_rb,7.477725e-01_rb,7.504362e-01_rb,&
- & 7.530846e-01_rb,7.557159e-01_rb,7.583283e-01_rb,7.609199e-01_rb,7.634888e-01_rb,&
- & 7.660332e-01_rb,7.685512e-01_rb,7.710411e-01_rb,7.735009e-01_rb,7.759288e-01_rb,&
- & 7.783229e-01_rb,7.806814e-01_rb,7.830024e-01_rb,7.852841e-01_rb,7.875246e-01_rb,&
- & 7.897221e-01_rb,7.918748e-01_rb,7.939807e-01_rb,7.960380e-01_rb,7.980449e-01_rb,&
- & 7.999995e-01_rb,8.019000e-01_rb,8.037445e-01_rb,8.055311e-01_rb,8.072581e-01_rb,&
- & 8.089235e-01_rb,8.105255e-01_rb,8.120623e-01_rb,8.135319e-01_rb,8.149326e-01_rb,&
- & 8.162626e-01_rb,8.175198e-01_rb,8.187025e-01_rb,8.198089e-01_rb,8.208371e-01_rb,&
- & 8.217852e-01_rb,8.226514e-01_rb,8.234338e-01_rb,8.241306e-01_rb,8.247399e-01_rb,&
- & 8.252599e-01_rb /)
- asyice3(:, 28) = (/ &
-! band 28
- & 7.224533e-01_rb,7.251681e-01_rb,7.278728e-01_rb,7.305654e-01_rb,7.332444e-01_rb,&
- & 7.359078e-01_rb,7.385539e-01_rb,7.411808e-01_rb,7.437869e-01_rb,7.463702e-01_rb,&
- & 7.489291e-01_rb,7.514616e-01_rb,7.539661e-01_rb,7.564408e-01_rb,7.588837e-01_rb,&
- & 7.612933e-01_rb,7.636676e-01_rb,7.660049e-01_rb,7.683034e-01_rb,7.705612e-01_rb,&
- & 7.727767e-01_rb,7.749480e-01_rb,7.770733e-01_rb,7.791509e-01_rb,7.811789e-01_rb,&
- & 7.831556e-01_rb,7.850791e-01_rb,7.869478e-01_rb,7.887597e-01_rb,7.905131e-01_rb,&
- & 7.922062e-01_rb,7.938372e-01_rb,7.954044e-01_rb,7.969059e-01_rb,7.983399e-01_rb,&
- & 7.997047e-01_rb,8.009985e-01_rb,8.022195e-01_rb,8.033658e-01_rb,8.044357e-01_rb,&
- & 8.054275e-01_rb,8.063392e-01_rb,8.071692e-01_rb,8.079157e-01_rb,8.085768e-01_rb,&
- & 8.091507e-01_rb /)
- asyice3(:, 29) = (/ &
-! band 29
- & 8.850026e-01_rb,9.005489e-01_rb,9.069242e-01_rb,9.121799e-01_rb,9.168987e-01_rb,&
- & 9.212259e-01_rb,9.252176e-01_rb,9.289028e-01_rb,9.323000e-01_rb,9.354235e-01_rb,&
- & 9.382858e-01_rb,9.408985e-01_rb,9.432734e-01_rb,9.454218e-01_rb,9.473557e-01_rb,&
- & 9.490871e-01_rb,9.506282e-01_rb,9.519917e-01_rb,9.531904e-01_rb,9.542374e-01_rb,&
- & 9.551461e-01_rb,9.559298e-01_rb,9.566023e-01_rb,9.571775e-01_rb,9.576692e-01_rb,&
- & 9.580916e-01_rb,9.584589e-01_rb,9.587853e-01_rb,9.590851e-01_rb,9.593729e-01_rb,&
- & 9.596632e-01_rb,9.599705e-01_rb,9.603096e-01_rb,9.606954e-01_rb,9.611427e-01_rb,&
- & 9.616667e-01_rb,9.622826e-01_rb,9.630060e-01_rb,9.638524e-01_rb,9.648379e-01_rb,&
- & 9.659788e-01_rb,9.672916e-01_rb,9.687933e-01_rb,9.705014e-01_rb,9.724337e-01_rb,&
- & 9.746084e-01_rb /)
-
-! fdelta: unitless
- fdlice3(:, 16) = (/ &
-! band 16
- & 4.959277e-02_rb,4.685292e-02_rb,4.426104e-02_rb,4.181231e-02_rb,3.950191e-02_rb,&
- & 3.732500e-02_rb,3.527675e-02_rb,3.335235e-02_rb,3.154697e-02_rb,2.985578e-02_rb,&
- & 2.827395e-02_rb,2.679666e-02_rb,2.541909e-02_rb,2.413640e-02_rb,2.294378e-02_rb,&
- & 2.183639e-02_rb,2.080940e-02_rb,1.985801e-02_rb,1.897736e-02_rb,1.816265e-02_rb,&
- & 1.740905e-02_rb,1.671172e-02_rb,1.606585e-02_rb,1.546661e-02_rb,1.490917e-02_rb,&
- & 1.438870e-02_rb,1.390038e-02_rb,1.343939e-02_rb,1.300089e-02_rb,1.258006e-02_rb,&
- & 1.217208e-02_rb,1.177212e-02_rb,1.137536e-02_rb,1.097696e-02_rb,1.057210e-02_rb,&
- & 1.015596e-02_rb,9.723704e-03_rb,9.270516e-03_rb,8.791565e-03_rb,8.282026e-03_rb,&
- & 7.737072e-03_rb,7.151879e-03_rb,6.521619e-03_rb,5.841467e-03_rb,5.106597e-03_rb,&
- & 4.312183e-03_rb /)
- fdlice3(:, 17) = (/ &
-! band 17
- & 5.071224e-02_rb,5.000217e-02_rb,4.933872e-02_rb,4.871992e-02_rb,4.814380e-02_rb,&
- & 4.760839e-02_rb,4.711170e-02_rb,4.665177e-02_rb,4.622662e-02_rb,4.583426e-02_rb,&
- & 4.547274e-02_rb,4.514007e-02_rb,4.483428e-02_rb,4.455340e-02_rb,4.429544e-02_rb,&
- & 4.405844e-02_rb,4.384041e-02_rb,4.363939e-02_rb,4.345340e-02_rb,4.328047e-02_rb,&
- & 4.311861e-02_rb,4.296586e-02_rb,4.282024e-02_rb,4.267977e-02_rb,4.254248e-02_rb,&
- & 4.240640e-02_rb,4.226955e-02_rb,4.212995e-02_rb,4.198564e-02_rb,4.183462e-02_rb,&
- & 4.167494e-02_rb,4.150462e-02_rb,4.132167e-02_rb,4.112413e-02_rb,4.091003e-02_rb,&
- & 4.067737e-02_rb,4.042420e-02_rb,4.014854e-02_rb,3.984840e-02_rb,3.952183e-02_rb,&
- & 3.916683e-02_rb,3.878144e-02_rb,3.836368e-02_rb,3.791158e-02_rb,3.742316e-02_rb,&
- & 3.689645e-02_rb /)
- fdlice3(:, 18) = (/ &
-! band 18
- & 1.062938e-01_rb,1.065234e-01_rb,1.067822e-01_rb,1.070682e-01_rb,1.073793e-01_rb,&
- & 1.077137e-01_rb,1.080693e-01_rb,1.084442e-01_rb,1.088364e-01_rb,1.092439e-01_rb,&
- & 1.096647e-01_rb,1.100970e-01_rb,1.105387e-01_rb,1.109878e-01_rb,1.114423e-01_rb,&
- & 1.119004e-01_rb,1.123599e-01_rb,1.128190e-01_rb,1.132757e-01_rb,1.137279e-01_rb,&
- & 1.141738e-01_rb,1.146113e-01_rb,1.150385e-01_rb,1.154534e-01_rb,1.158540e-01_rb,&
- & 1.162383e-01_rb,1.166045e-01_rb,1.169504e-01_rb,1.172741e-01_rb,1.175738e-01_rb,&
- & 1.178472e-01_rb,1.180926e-01_rb,1.183080e-01_rb,1.184913e-01_rb,1.186405e-01_rb,&
- & 1.187538e-01_rb,1.188291e-01_rb,1.188645e-01_rb,1.188580e-01_rb,1.188076e-01_rb,&
- & 1.187113e-01_rb,1.185672e-01_rb,1.183733e-01_rb,1.181277e-01_rb,1.178282e-01_rb,&
- & 1.174731e-01_rb /)
- fdlice3(:, 19) = (/ &
-! band 19
- & 1.076195e-01_rb,1.065195e-01_rb,1.054696e-01_rb,1.044673e-01_rb,1.035099e-01_rb,&
- & 1.025951e-01_rb,1.017203e-01_rb,1.008831e-01_rb,1.000808e-01_rb,9.931116e-02_rb,&
- & 9.857151e-02_rb,9.785939e-02_rb,9.717230e-02_rb,9.650774e-02_rb,9.586322e-02_rb,&
- & 9.523623e-02_rb,9.462427e-02_rb,9.402484e-02_rb,9.343544e-02_rb,9.285358e-02_rb,&
- & 9.227675e-02_rb,9.170245e-02_rb,9.112818e-02_rb,9.055144e-02_rb,8.996974e-02_rb,&
- & 8.938056e-02_rb,8.878142e-02_rb,8.816981e-02_rb,8.754323e-02_rb,8.689919e-02_rb,&
- & 8.623517e-02_rb,8.554869e-02_rb,8.483724e-02_rb,8.409832e-02_rb,8.332943e-02_rb,&
- & 8.252807e-02_rb,8.169175e-02_rb,8.081795e-02_rb,7.990419e-02_rb,7.894796e-02_rb,&
- & 7.794676e-02_rb,7.689809e-02_rb,7.579945e-02_rb,7.464834e-02_rb,7.344227e-02_rb,&
- & 7.217872e-02_rb /)
- fdlice3(:, 20) = (/ &
-! band 20
- & 1.119014e-01_rb,1.122706e-01_rb,1.126690e-01_rb,1.130947e-01_rb,1.135456e-01_rb,&
- & 1.140199e-01_rb,1.145154e-01_rb,1.150302e-01_rb,1.155623e-01_rb,1.161096e-01_rb,&
- & 1.166703e-01_rb,1.172422e-01_rb,1.178233e-01_rb,1.184118e-01_rb,1.190055e-01_rb,&
- & 1.196025e-01_rb,1.202008e-01_rb,1.207983e-01_rb,1.213931e-01_rb,1.219832e-01_rb,&
- & 1.225665e-01_rb,1.231411e-01_rb,1.237050e-01_rb,1.242561e-01_rb,1.247926e-01_rb,&
- & 1.253122e-01_rb,1.258132e-01_rb,1.262934e-01_rb,1.267509e-01_rb,1.271836e-01_rb,&
- & 1.275896e-01_rb,1.279669e-01_rb,1.283134e-01_rb,1.286272e-01_rb,1.289063e-01_rb,&
- & 1.291486e-01_rb,1.293522e-01_rb,1.295150e-01_rb,1.296351e-01_rb,1.297104e-01_rb,&
- & 1.297390e-01_rb,1.297189e-01_rb,1.296480e-01_rb,1.295244e-01_rb,1.293460e-01_rb,&
- & 1.291109e-01_rb /)
- fdlice3(:, 21) = (/ &
-! band 21
- & 1.133298e-01_rb,1.136777e-01_rb,1.140556e-01_rb,1.144615e-01_rb,1.148934e-01_rb,&
- & 1.153492e-01_rb,1.158269e-01_rb,1.163243e-01_rb,1.168396e-01_rb,1.173706e-01_rb,&
- & 1.179152e-01_rb,1.184715e-01_rb,1.190374e-01_rb,1.196108e-01_rb,1.201897e-01_rb,&
- & 1.207720e-01_rb,1.213558e-01_rb,1.219389e-01_rb,1.225194e-01_rb,1.230951e-01_rb,&
- & 1.236640e-01_rb,1.242241e-01_rb,1.247733e-01_rb,1.253096e-01_rb,1.258309e-01_rb,&
- & 1.263352e-01_rb,1.268205e-01_rb,1.272847e-01_rb,1.277257e-01_rb,1.281415e-01_rb,&
- & 1.285300e-01_rb,1.288893e-01_rb,1.292173e-01_rb,1.295118e-01_rb,1.297710e-01_rb,&
- & 1.299927e-01_rb,1.301748e-01_rb,1.303154e-01_rb,1.304124e-01_rb,1.304637e-01_rb,&
- & 1.304673e-01_rb,1.304212e-01_rb,1.303233e-01_rb,1.301715e-01_rb,1.299638e-01_rb,&
- & 1.296983e-01_rb /)
- fdlice3(:, 22) = (/ &
-! band 22
- & 1.145360e-01_rb,1.153256e-01_rb,1.161453e-01_rb,1.169929e-01_rb,1.178666e-01_rb,&
- & 1.187641e-01_rb,1.196835e-01_rb,1.206227e-01_rb,1.215796e-01_rb,1.225522e-01_rb,&
- & 1.235383e-01_rb,1.245361e-01_rb,1.255433e-01_rb,1.265579e-01_rb,1.275779e-01_rb,&
- & 1.286011e-01_rb,1.296257e-01_rb,1.306494e-01_rb,1.316703e-01_rb,1.326862e-01_rb,&
- & 1.336951e-01_rb,1.346950e-01_rb,1.356838e-01_rb,1.366594e-01_rb,1.376198e-01_rb,&
- & 1.385629e-01_rb,1.394866e-01_rb,1.403889e-01_rb,1.412678e-01_rb,1.421212e-01_rb,&
- & 1.429469e-01_rb,1.437430e-01_rb,1.445074e-01_rb,1.452381e-01_rb,1.459329e-01_rb,&
- & 1.465899e-01_rb,1.472069e-01_rb,1.477819e-01_rb,1.483128e-01_rb,1.487976e-01_rb,&
- & 1.492343e-01_rb,1.496207e-01_rb,1.499548e-01_rb,1.502346e-01_rb,1.504579e-01_rb,&
- & 1.506227e-01_rb /)
- fdlice3(:, 23) = (/ &
-! band 23
- & 1.153263e-01_rb,1.161445e-01_rb,1.169932e-01_rb,1.178703e-01_rb,1.187738e-01_rb,&
- & 1.197016e-01_rb,1.206516e-01_rb,1.216217e-01_rb,1.226099e-01_rb,1.236141e-01_rb,&
- & 1.246322e-01_rb,1.256621e-01_rb,1.267017e-01_rb,1.277491e-01_rb,1.288020e-01_rb,&
- & 1.298584e-01_rb,1.309163e-01_rb,1.319736e-01_rb,1.330281e-01_rb,1.340778e-01_rb,&
- & 1.351207e-01_rb,1.361546e-01_rb,1.371775e-01_rb,1.381873e-01_rb,1.391820e-01_rb,&
- & 1.401593e-01_rb,1.411174e-01_rb,1.420540e-01_rb,1.429671e-01_rb,1.438547e-01_rb,&
- & 1.447146e-01_rb,1.455449e-01_rb,1.463433e-01_rb,1.471078e-01_rb,1.478364e-01_rb,&
- & 1.485270e-01_rb,1.491774e-01_rb,1.497857e-01_rb,1.503497e-01_rb,1.508674e-01_rb,&
- & 1.513367e-01_rb,1.517554e-01_rb,1.521216e-01_rb,1.524332e-01_rb,1.526880e-01_rb,&
- & 1.528840e-01_rb /)
- fdlice3(:, 24) = (/ &
-! band 24
- & 1.160842e-01_rb,1.169118e-01_rb,1.177697e-01_rb,1.186556e-01_rb,1.195676e-01_rb,&
- & 1.205036e-01_rb,1.214616e-01_rb,1.224394e-01_rb,1.234349e-01_rb,1.244463e-01_rb,&
- & 1.254712e-01_rb,1.265078e-01_rb,1.275539e-01_rb,1.286075e-01_rb,1.296664e-01_rb,&
- & 1.307287e-01_rb,1.317923e-01_rb,1.328550e-01_rb,1.339149e-01_rb,1.349699e-01_rb,&
- & 1.360179e-01_rb,1.370567e-01_rb,1.380845e-01_rb,1.390991e-01_rb,1.400984e-01_rb,&
- & 1.410803e-01_rb,1.420429e-01_rb,1.429840e-01_rb,1.439016e-01_rb,1.447936e-01_rb,&
- & 1.456579e-01_rb,1.464925e-01_rb,1.472953e-01_rb,1.480642e-01_rb,1.487972e-01_rb,&
- & 1.494923e-01_rb,1.501472e-01_rb,1.507601e-01_rb,1.513287e-01_rb,1.518511e-01_rb,&
- & 1.523252e-01_rb,1.527489e-01_rb,1.531201e-01_rb,1.534368e-01_rb,1.536969e-01_rb,&
- & 1.538984e-01_rb /)
- fdlice3(:, 25) = (/ &
-! band 25
- & 1.168725e-01_rb,1.177088e-01_rb,1.185747e-01_rb,1.194680e-01_rb,1.203867e-01_rb,&
- & 1.213288e-01_rb,1.222923e-01_rb,1.232750e-01_rb,1.242750e-01_rb,1.252903e-01_rb,&
- & 1.263187e-01_rb,1.273583e-01_rb,1.284069e-01_rb,1.294626e-01_rb,1.305233e-01_rb,&
- & 1.315870e-01_rb,1.326517e-01_rb,1.337152e-01_rb,1.347756e-01_rb,1.358308e-01_rb,&
- & 1.368788e-01_rb,1.379175e-01_rb,1.389449e-01_rb,1.399590e-01_rb,1.409577e-01_rb,&
- & 1.419389e-01_rb,1.429007e-01_rb,1.438410e-01_rb,1.447577e-01_rb,1.456488e-01_rb,&
- & 1.465123e-01_rb,1.473461e-01_rb,1.481483e-01_rb,1.489166e-01_rb,1.496492e-01_rb,&
- & 1.503439e-01_rb,1.509988e-01_rb,1.516118e-01_rb,1.521808e-01_rb,1.527038e-01_rb,&
- & 1.531788e-01_rb,1.536037e-01_rb,1.539764e-01_rb,1.542951e-01_rb,1.545575e-01_rb,&
- & 1.547617e-01_rb /)
- fdlice3(:, 26) = (/ &
-!band 26
- & 1.180509e-01_rb,1.189025e-01_rb,1.197820e-01_rb,1.206875e-01_rb,1.216171e-01_rb,&
- & 1.225687e-01_rb,1.235404e-01_rb,1.245303e-01_rb,1.255363e-01_rb,1.265564e-01_rb,&
- & 1.275888e-01_rb,1.286313e-01_rb,1.296821e-01_rb,1.307392e-01_rb,1.318006e-01_rb,&
- & 1.328643e-01_rb,1.339284e-01_rb,1.349908e-01_rb,1.360497e-01_rb,1.371029e-01_rb,&
- & 1.381486e-01_rb,1.391848e-01_rb,1.402095e-01_rb,1.412208e-01_rb,1.422165e-01_rb,&
- & 1.431949e-01_rb,1.441539e-01_rb,1.450915e-01_rb,1.460058e-01_rb,1.468947e-01_rb,&
- & 1.477564e-01_rb,1.485888e-01_rb,1.493900e-01_rb,1.501580e-01_rb,1.508907e-01_rb,&
- & 1.515864e-01_rb,1.522428e-01_rb,1.528582e-01_rb,1.534305e-01_rb,1.539578e-01_rb,&
- & 1.544380e-01_rb,1.548692e-01_rb,1.552494e-01_rb,1.555767e-01_rb,1.558490e-01_rb,&
- & 1.560645e-01_rb /)
- fdlice3(:, 27) = (/ &
-! band 27
- & 1.200480e-01_rb,1.209267e-01_rb,1.218304e-01_rb,1.227575e-01_rb,1.237059e-01_rb,&
- & 1.246739e-01_rb,1.256595e-01_rb,1.266610e-01_rb,1.276765e-01_rb,1.287041e-01_rb,&
- & 1.297420e-01_rb,1.307883e-01_rb,1.318412e-01_rb,1.328988e-01_rb,1.339593e-01_rb,&
- & 1.350207e-01_rb,1.360813e-01_rb,1.371393e-01_rb,1.381926e-01_rb,1.392396e-01_rb,&
- & 1.402783e-01_rb,1.413069e-01_rb,1.423235e-01_rb,1.433263e-01_rb,1.443134e-01_rb,&
- & 1.452830e-01_rb,1.462332e-01_rb,1.471622e-01_rb,1.480681e-01_rb,1.489490e-01_rb,&
- & 1.498032e-01_rb,1.506286e-01_rb,1.514236e-01_rb,1.521863e-01_rb,1.529147e-01_rb,&
- & 1.536070e-01_rb,1.542614e-01_rb,1.548761e-01_rb,1.554491e-01_rb,1.559787e-01_rb,&
- & 1.564629e-01_rb,1.568999e-01_rb,1.572879e-01_rb,1.576249e-01_rb,1.579093e-01_rb,&
- & 1.581390e-01_rb /)
- fdlice3(:, 28) = (/ &
-! band 28
- & 1.247813e-01_rb,1.256496e-01_rb,1.265417e-01_rb,1.274560e-01_rb,1.283905e-01_rb,&
- & 1.293436e-01_rb,1.303135e-01_rb,1.312983e-01_rb,1.322964e-01_rb,1.333060e-01_rb,&
- & 1.343252e-01_rb,1.353523e-01_rb,1.363855e-01_rb,1.374231e-01_rb,1.384632e-01_rb,&
- & 1.395042e-01_rb,1.405441e-01_rb,1.415813e-01_rb,1.426140e-01_rb,1.436404e-01_rb,&
- & 1.446587e-01_rb,1.456672e-01_rb,1.466640e-01_rb,1.476475e-01_rb,1.486157e-01_rb,&
- & 1.495671e-01_rb,1.504997e-01_rb,1.514117e-01_rb,1.523016e-01_rb,1.531673e-01_rb,&
- & 1.540073e-01_rb,1.548197e-01_rb,1.556026e-01_rb,1.563545e-01_rb,1.570734e-01_rb,&
- & 1.577576e-01_rb,1.584054e-01_rb,1.590149e-01_rb,1.595843e-01_rb,1.601120e-01_rb,&
- & 1.605962e-01_rb,1.610349e-01_rb,1.614266e-01_rb,1.617693e-01_rb,1.620614e-01_rb,&
- & 1.623011e-01_rb /)
- fdlice3(:, 29) = (/ &
-! band 29
- & 1.006055e-01_rb,9.549582e-02_rb,9.063960e-02_rb,8.602900e-02_rb,8.165612e-02_rb,&
- & 7.751308e-02_rb,7.359199e-02_rb,6.988496e-02_rb,6.638412e-02_rb,6.308156e-02_rb,&
- & 5.996942e-02_rb,5.703979e-02_rb,5.428481e-02_rb,5.169657e-02_rb,4.926719e-02_rb,&
- & 4.698880e-02_rb,4.485349e-02_rb,4.285339e-02_rb,4.098061e-02_rb,3.922727e-02_rb,&
- & 3.758547e-02_rb,3.604733e-02_rb,3.460497e-02_rb,3.325051e-02_rb,3.197604e-02_rb,&
- & 3.077369e-02_rb,2.963558e-02_rb,2.855381e-02_rb,2.752050e-02_rb,2.652776e-02_rb,&
- & 2.556772e-02_rb,2.463247e-02_rb,2.371415e-02_rb,2.280485e-02_rb,2.189670e-02_rb,&
- & 2.098180e-02_rb,2.005228e-02_rb,1.910024e-02_rb,1.811781e-02_rb,1.709709e-02_rb,&
- & 1.603020e-02_rb,1.490925e-02_rb,1.372635e-02_rb,1.247363e-02_rb,1.114319e-02_rb,&
- & 9.727157e-03_rb /)
-
- end subroutine swcldpr
-
- end module rrtmg_sw_init
-
-! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
-! author: $Author: trn $
-! revision: $Revision: 1.3 $
-! created: $Date: 2009/04/16 19:54:22 $
-!
- module rrtmg_sw_vrtqdr
-
-! --------------------------------------------------------------------------
-! | |
-! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
-! | This software may be used, copied, or redistributed as long as it is |
-! | not sold and this copyright notice is reproduced on each copy made. |
-! | This model is provided as is without any express or implied warranties. |
-! | (http://www.rtweb.aer.com/) |
-! | |
-! --------------------------------------------------------------------------
-
-! ------- Modules -------
-
- use parkind, only: im => kind_im, rb => kind_rb
-! use parrrsw, only: ngptsw
-
- implicit none
-
- contains
-
-! --------------------------------------------------------------------------
- subroutine vrtqdr_sw(klev, kw, &
- pref, prefd, ptra, ptrad, &
- pdbt, prdnd, prup, prupd, ptdbt, &
- pfd, pfu)
-! --------------------------------------------------------------------------
-
-! Purpose: This routine performs the vertical quadrature integration
-!
-! Interface: *vrtqdr_sw* is called from *spcvrt_sw* and *spcvmc_sw*
-!
-! Modifications.
-!
-! Original: H. Barker
-! Revision: Integrated with rrtmg_sw, J.-J. Morcrette, ECMWF, Oct 2002
-! Revision: Reformatted for consistency with rrtmg_lw: MJIacono, AER, Jul 2006
-!
-!-----------------------------------------------------------------------
-
-! ------- Declarations -------
-
-! Input
-
- integer(kind=im), intent (in) :: klev ! number of model layers
- integer(kind=im), intent (in) :: kw ! g-point index
-
- real(kind=rb), intent(in) :: pref(:) ! direct beam reflectivity
- ! Dimensions: (nlayers+1)
- real(kind=rb), intent(in) :: prefd(:) ! diffuse beam reflectivity
- ! Dimensions: (nlayers+1)
- real(kind=rb), intent(in) :: ptra(:) ! direct beam transmissivity
- ! Dimensions: (nlayers+1)
- real(kind=rb), intent(in) :: ptrad(:) ! diffuse beam transmissivity
- ! Dimensions: (nlayers+1)
-
- real(kind=rb), intent(in) :: pdbt(:)
- ! Dimensions: (nlayers+1)
- real(kind=rb), intent(in) :: ptdbt(:)
- ! Dimensions: (nlayers+1)
-
- real(kind=rb), intent(inout) :: prdnd(:)
- ! Dimensions: (nlayers+1)
- real(kind=rb), intent(inout) :: prup(:)
- ! Dimensions: (nlayers+1)
- real(kind=rb), intent(inout) :: prupd(:)
- ! Dimensions: (nlayers+1)
-
-! Output
- real(kind=rb), intent(out) :: pfd(:,:) ! downwelling flux (W/m2)
- ! Dimensions: (nlayers+1,ngptsw)
- ! unadjusted for earth/sun distance or zenith angle
- real(kind=rb), intent(out) :: pfu(:,:) ! upwelling flux (W/m2)
- ! Dimensions: (nlayers+1,ngptsw)
- ! unadjusted for earth/sun distance or zenith angle
-
-! Local
-
- integer(kind=im) :: ikp, ikx, jk
-
- real(kind=rb) :: zreflect
- real(kind=rb) :: ztdn(klev+1)
-
-! Definitions
-!
-! pref(jk) direct reflectance
-! prefd(jk) diffuse reflectance
-! ptra(jk) direct transmittance
-! ptrad(jk) diffuse transmittance
-!
-! pdbt(jk) layer mean direct beam transmittance
-! ptdbt(jk) total direct beam transmittance at levels
-!
-!-----------------------------------------------------------------------------
-
-! Link lowest layer with surface
-
- zreflect = 1._rb / (1._rb - prefd(klev+1) * prefd(klev))
- prup(klev) = pref(klev) + (ptrad(klev) * &
- ((ptra(klev) - pdbt(klev)) * prefd(klev+1) + &
- pdbt(klev) * pref(klev+1))) * zreflect
- prupd(klev) = prefd(klev) + ptrad(klev) * ptrad(klev) * &
- prefd(klev+1) * zreflect
-
-! Pass from bottom to top
-
- do jk = 1,klev-1
- ikp = klev+1-jk
- ikx = ikp-1
- zreflect = 1._rb / (1._rb -prupd(ikp) * prefd(ikx))
- prup(ikx) = pref(ikx) + (ptrad(ikx) * &
- ((ptra(ikx) - pdbt(ikx)) * prupd(ikp) + &
- pdbt(ikx) * prup(ikp))) * zreflect
- prupd(ikx) = prefd(ikx) + ptrad(ikx) * ptrad(ikx) * &
- prupd(ikp) * zreflect
- enddo
-
-! Upper boundary conditions
-
- ztdn(1) = 1._rb
- prdnd(1) = 0._rb
- ztdn(2) = ptra(1)
- prdnd(2) = prefd(1)
-
-! Pass from top to bottom
-
- do jk = 2,klev
- ikp = jk+1
- zreflect = 1._rb / (1._rb - prefd(jk) * prdnd(jk))
- ztdn(ikp) = ptdbt(jk) * ptra(jk) + &
- (ptrad(jk) * ((ztdn(jk) - ptdbt(jk)) + &
- ptdbt(jk) * pref(jk) * prdnd(jk))) * zreflect
- prdnd(ikp) = prefd(jk) + ptrad(jk) * ptrad(jk) * &
- prdnd(jk) * zreflect
- enddo
-
-! Up and down-welling fluxes at levels
-
- do jk = 1,klev+1
- zreflect = 1._rb / (1._rb - prdnd(jk) * prupd(jk))
- pfu(jk,kw) = (ptdbt(jk) * prup(jk) + &
- (ztdn(jk) - ptdbt(jk)) * prupd(jk)) * zreflect
- pfd(jk,kw) = ptdbt(jk) + (ztdn(jk) - ptdbt(jk)+ &
- ptdbt(jk) * prup(jk) * prdnd(jk)) * zreflect
- enddo
-
- end subroutine vrtqdr_sw
-
- end module rrtmg_sw_vrtqdr
-
-! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
-! author: $Author: trn $
-! revision: $Revision: 1.3 $
-! created: $Date: 2009/04/16 19:54:22 $
-
- module rrtmg_sw_spcvmc
-
-! --------------------------------------------------------------------------
-! | |
-! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
-! | This software may be used, copied, or redistributed as long as it is |
-! | not sold and this copyright notice is reproduced on each copy made. |
-! | This model is provided as is without any express or implied warranties. |
-! | (http://www.rtweb.aer.com/) |
-! | |
-! --------------------------------------------------------------------------
-
-! ------- Modules -------
-
- use parkind, only : im => kind_im, rb => kind_rb
- use parrrsw, only : nbndsw, ngptsw, mxmol, jpband
- use rrsw_tbl, only : tblint, bpade, od_lo, exp_tbl
- use rrsw_vsn, only : hvrspc, hnamspc
- use rrsw_wvn, only : ngc, ngs
- use rrtmg_sw_reftra, only: reftra_sw
- use rrtmg_sw_taumol, only: taumol_sw
- use rrtmg_sw_vrtqdr, only: vrtqdr_sw
-
- implicit none
-
- contains
-
-! ---------------------------------------------------------------------------
- subroutine spcvmc_sw &
- (nlayers, istart, iend, icpr, iout, &
- pavel, tavel, pz, tz, tbound, palbd, palbp, &
- pcldfmc, ptaucmc, pasycmc, pomgcmc, ptaormc, &
- ptaua, pasya, pomga, prmu0, coldry, wkl, adjflux, &
- laytrop, layswtch, laylow, jp, jt, jt1, &
- co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3, &
- fac00, fac01, fac10, fac11, &
- selffac, selffrac, indself, forfac, forfrac, indfor, &
- pbbfd, pbbfu, pbbcd, pbbcu, puvfd, puvcd, pnifd, pnicd, &
- pbbfddir, pbbcddir, puvfddir, puvcddir, pnifddir, pnicddir)
-! ---------------------------------------------------------------------------
-!
-! Purpose: Contains spectral loop to compute the shortwave radiative fluxes,
-! using the two-stream method of H. Barker and McICA, the Monte-Carlo
-! Independent Column Approximation, for the representation of
-! sub-grid cloud variability (i.e. cloud overlap).
-!
-! Interface: *spcvmc_sw* is called from *rrtmg_sw.F90* or rrtmg_sw.1col.F90*
-!
-! Method:
-! Adapted from two-stream model of H. Barker;
-! Two-stream model options (selected with kmodts in rrtmg_sw_reftra.F90):
-! 1: Eddington, 2: PIFM, Zdunkowski et al., 3: discret ordinates
-!
-! Modifications:
-!
-! Original: H. Barker
-! Revision: Merge with RRTMG_SW: J.-J.Morcrette, ECMWF, Feb 2003
-! Revision: Add adjustment for Earth/Sun distance : MJIacono, AER, Oct 2003
-! Revision: Bug fix for use of PALBP and PALBD: MJIacono, AER, Nov 2003
-! Revision: Bug fix to apply delta scaling to clear sky: AER, Dec 2004
-! Revision: Code modified so that delta scaling is not done in cloudy profiles
-! if routine cldprop is used; delta scaling can be applied by swithcing
-! code below if cldprop is not used to get cloud properties.
-! AER, Jan 2005
-! Revision: Modified to use McICA: MJIacono, AER, Nov 2005
-! Revision: Uniform formatting for RRTMG: MJIacono, AER, Jul 2006
-! Revision: Use exponential lookup table for transmittance: MJIacono, AER,
-! Aug 2007
-!
-! ------------------------------------------------------------------
-
-! ------- Declarations ------
-
-! ------- Input -------
-
- integer(kind=im), intent(in) :: nlayers
- integer(kind=im), intent(in) :: istart
- integer(kind=im), intent(in) :: iend
- integer(kind=im), intent(in) :: icpr
- integer(kind=im), intent(in) :: iout
- integer(kind=im), intent(in) :: laytrop
- integer(kind=im), intent(in) :: layswtch
- integer(kind=im), intent(in) :: laylow
-
- integer(kind=im), intent(in) :: indfor(:)
- ! Dimensions: (nlayers)
- integer(kind=im), intent(in) :: indself(:)
- ! Dimensions: (nlayers)
- integer(kind=im), intent(in) :: jp(:)
- ! Dimensions: (nlayers)
- integer(kind=im), intent(in) :: jt(:)
- ! Dimensions: (nlayers)
- integer(kind=im), intent(in) :: jt1(:)
- ! Dimensions: (nlayers)
-
- real(kind=rb), intent(in) :: pavel(:) ! layer pressure (hPa, mb)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: tavel(:) ! layer temperature (K)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: pz(0:) ! level (interface) pressure (hPa, mb)
- ! Dimensions: (0:nlayers)
- real(kind=rb), intent(in) :: tz(0:) ! level temperatures (hPa, mb)
- ! Dimensions: (0:nlayers)
- real(kind=rb), intent(in) :: tbound ! surface temperature (K)
- real(kind=rb), intent(in) :: wkl(:,:) ! molecular amounts (mol/cm2)
- ! Dimensions: (mxmol,nlayers)
- real(kind=rb), intent(in) :: coldry(:) ! dry air column density (mol/cm2)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: colmol(:)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: adjflux(:) ! Earth/Sun distance adjustment
- ! Dimensions: (jpband)
-
- real(kind=rb), intent(in) :: palbd(:) ! surface albedo (diffuse)
- ! Dimensions: (nbndsw)
- real(kind=rb), intent(in) :: palbp(:) ! surface albedo (direct)
- ! Dimensions: (nbndsw)
- real(kind=rb), intent(in) :: prmu0 ! cosine of solar zenith angle
- real(kind=rb), intent(in) :: pcldfmc(:,:) ! cloud fraction [mcica]
- ! Dimensions: (nlayers,ngptsw)
- real(kind=rb), intent(in) :: ptaucmc(:,:) ! cloud optical depth [mcica]
- ! Dimensions: (nlayers,ngptsw)
- real(kind=rb), intent(in) :: pasycmc(:,:) ! cloud asymmetry parameter [mcica]
- ! Dimensions: (nlayers,ngptsw)
- real(kind=rb), intent(in) :: pomgcmc(:,:) ! cloud single scattering albedo [mcica]
- ! Dimensions: (nlayers,ngptsw)
- real(kind=rb), intent(in) :: ptaormc(:,:) ! cloud optical depth, non-delta scaled [mcica]
- ! Dimensions: (nlayers,ngptsw)
- real(kind=rb), intent(in) :: ptaua(:,:) ! aerosol optical depth
- ! Dimensions: (nlayers,nbndsw)
- real(kind=rb), intent(in) :: pasya(:,:) ! aerosol asymmetry parameter
- ! Dimensions: (nlayers,nbndsw)
- real(kind=rb), intent(in) :: pomga(:,:) ! aerosol single scattering albedo
- ! Dimensions: (nlayers,nbndsw)
-
- real(kind=rb), intent(in) :: colh2o(:)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: colco2(:)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: colch4(:)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: co2mult(:)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: colo3(:)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: colo2(:)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: coln2o(:)
- ! Dimensions: (nlayers)
-
- real(kind=rb), intent(in) :: forfac(:)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: forfrac(:)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: selffac(:)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: selffrac(:)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: fac00(:)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: fac01(:)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: fac10(:)
- ! Dimensions: (nlayers)
- real(kind=rb), intent(in) :: fac11(:)
- ! Dimensions: (nlayers)
-
-! ------- Output -------
- ! All Dimensions: (nlayers+1)
- real(kind=rb), intent(out) :: pbbcd(:)
- real(kind=rb), intent(out) :: pbbcu(:)
- real(kind=rb), intent(out) :: pbbfd(:)
- real(kind=rb), intent(out) :: pbbfu(:)
- real(kind=rb), intent(out) :: pbbfddir(:)
- real(kind=rb), intent(out) :: pbbcddir(:)
-
- real(kind=rb), intent(out) :: puvcd(:)
- real(kind=rb), intent(out) :: puvfd(:)
- real(kind=rb), intent(out) :: puvcddir(:)
- real(kind=rb), intent(out) :: puvfddir(:)
-
- real(kind=rb), intent(out) :: pnicd(:)
- real(kind=rb), intent(out) :: pnifd(:)
- real(kind=rb), intent(out) :: pnicddir(:)
- real(kind=rb), intent(out) :: pnifddir(:)
-
-! Output - inactive ! All Dimensions: (nlayers+1)
-! real(kind=rb), intent(out) :: puvcu(:)
-! real(kind=rb), intent(out) :: puvfu(:)
-! real(kind=rb), intent(out) :: pnicu(:)
-! real(kind=rb), intent(out) :: pnifu(:)
-! real(kind=rb), intent(out) :: pvscd(:)
-! real(kind=rb), intent(out) :: pvscu(:)
-! real(kind=rb), intent(out) :: pvsfd(:)
-! real(kind=rb), intent(out) :: pvsfu(:)
-
-! ------- Local -------
-
- logical :: lrtchkclr(nlayers),lrtchkcld(nlayers)
-
- integer(kind=im) :: klev
- integer(kind=im) :: ib1, ib2, ibm, igt, ikl, ikp, ikx
- integer(kind=im) :: iw, jb, jg, jl, jk
-! integer(kind=im), parameter :: nuv = ??
-! integer(kind=im), parameter :: nvs = ??
- integer(kind=im) :: itind
-
- real(kind=rb) :: tblind, ze1
- real(kind=rb) :: zclear, zcloud
- real(kind=rb) :: zdbt(nlayers+1), zdbt_nodel(nlayers+1)
- real(kind=rb) :: zgc(nlayers), zgcc(nlayers), zgco(nlayers)
- real(kind=rb) :: zomc(nlayers), zomcc(nlayers), zomco(nlayers)
- real(kind=rb) :: zrdnd(nlayers+1), zrdndc(nlayers+1)
- real(kind=rb) :: zref(nlayers+1), zrefc(nlayers+1), zrefo(nlayers+1)
- real(kind=rb) :: zrefd(nlayers+1), zrefdc(nlayers+1), zrefdo(nlayers+1)
- real(kind=rb) :: zrup(nlayers+1), zrupd(nlayers+1)
- real(kind=rb) :: zrupc(nlayers+1), zrupdc(nlayers+1)
- real(kind=rb) :: zs1(nlayers+1)
- real(kind=rb) :: ztauc(nlayers), ztauo(nlayers)
- real(kind=rb) :: ztdn(nlayers+1), ztdnd(nlayers+1), ztdbt(nlayers+1)
- real(kind=rb) :: ztoc(nlayers), ztor(nlayers)
- real(kind=rb) :: ztra(nlayers+1), ztrac(nlayers+1), ztrao(nlayers+1)
- real(kind=rb) :: ztrad(nlayers+1), ztradc(nlayers+1), ztrado(nlayers+1)
- real(kind=rb) :: zdbtc(nlayers+1), ztdbtc(nlayers+1)
- real(kind=rb) :: zincflx(ngptsw), zdbtc_nodel(nlayers+1)
- real(kind=rb) :: ztdbt_nodel(nlayers+1), ztdbtc_nodel(nlayers+1)
-
- real(kind=rb) :: zdbtmc, zdbtmo, zf, zgw, zreflect
- real(kind=rb) :: zwf, tauorig, repclc
-! real(kind=rb) :: zincflux ! inactive
-
-! Arrays from rrtmg_sw_taumoln routines
-
-! real(kind=rb) :: ztaug(nlayers,16), ztaur(nlayers,16)
-! real(kind=rb) :: zsflxzen(16)
- real(kind=rb) :: ztaug(nlayers,ngptsw), ztaur(nlayers,ngptsw)
- real(kind=rb) :: zsflxzen(ngptsw)
-
-! Arrays from rrtmg_sw_vrtqdr routine
-
- real(kind=rb) :: zcd(nlayers+1,ngptsw), zcu(nlayers+1,ngptsw)
- real(kind=rb) :: zfd(nlayers+1,ngptsw), zfu(nlayers+1,ngptsw)
-
-! Inactive arrays
-! real(kind=rb) :: zbbcd(nlayers+1), zbbcu(nlayers+1)
-! real(kind=rb) :: zbbfd(nlayers+1), zbbfu(nlayers+1)
-! real(kind=rb) :: zbbfddir(nlayers+1), zbbcddir(nlayers+1)
-
-! ------------------------------------------------------------------
-
-! Initializations
-
- ib1 = istart
- ib2 = iend
- klev = nlayers
- iw = 0
- repclc = 1.e-12_rb
-! zincflux = 0.0_rb
-
- do jk=1,klev+1
- pbbcd(jk)=0._rb
- pbbcu(jk)=0._rb
- pbbfd(jk)=0._rb
- pbbfu(jk)=0._rb
- pbbcddir(jk)=0._rb
- pbbfddir(jk)=0._rb
- puvcd(jk)=0._rb
- puvfd(jk)=0._rb
- puvcddir(jk)=0._rb
- puvfddir(jk)=0._rb
- pnicd(jk)=0._rb
- pnifd(jk)=0._rb
- pnicddir(jk)=0._rb
- pnifddir(jk)=0._rb
- enddo
-
-
-! Calculate the optical depths for gaseous absorption and Rayleigh scattering
-
- call taumol_sw(klev, &
- colh2o, colco2, colch4, colo2, colo3, colmol, &
- laytrop, jp, jt, jt1, &
- fac00, fac01, fac10, fac11, &
- selffac, selffrac, indself, forfac, forfrac, indfor, &
- zsflxzen, ztaug, ztaur)
-
-! Top of shortwave spectral band loop, jb = 16 -> 29; ibm = 1 -> 14
-
- do jb = ib1, ib2
- ibm = jb-15
- igt = ngc(ibm)
-
-! Reinitialize g-point counter for each band if output for each band is requested.
- if (iout.gt.0.and.ibm.ge.2) iw = ngs(ibm-1)
-
-! do jk=1,klev+1
-! zbbcd(jk)=0.0_rb
-! zbbcu(jk)=0.0_rb
-! zbbfd(jk)=0.0_rb
-! zbbfu(jk)=0.0_rb
-! enddo
-
-! Top of g-point interval loop within each band (iw is cumulative counter)
- do jg = 1,igt
- iw = iw+1
-
-! Apply adjustment for correct Earth/Sun distance and zenith angle to incoming solar flux
- zincflx(iw) = adjflux(jb) * zsflxzen(iw) * prmu0
-! zincflux = zincflux + adjflux(jb) * zsflxzen(iw) * prmu0 ! inactive
-
-! Compute layer reflectances and transmittances for direct and diffuse sources,
-! first clear then cloudy
-
-! zrefc(jk) direct albedo for clear
-! zrefo(jk) direct albedo for cloud
-! zrefdc(jk) diffuse albedo for clear
-! zrefdo(jk) diffuse albedo for cloud
-! ztrac(jk) direct transmittance for clear
-! ztrao(jk) direct transmittance for cloudy
-! ztradc(jk) diffuse transmittance for clear
-! ztrado(jk) diffuse transmittance for cloudy
-!
-! zref(jk) direct reflectance
-! zrefd(jk) diffuse reflectance
-! ztra(jk) direct transmittance
-! ztrad(jk) diffuse transmittance
-!
-! zdbtc(jk) clear direct beam transmittance
-! zdbto(jk) cloudy direct beam transmittance
-! zdbt(jk) layer mean direct beam transmittance
-! ztdbt(jk) total direct beam transmittance at levels
-
-! Clear-sky
-! TOA direct beam
- ztdbtc(1)=1.0_rb
- ztdbtc_nodel(1)=1.0_rb
-! Surface values
- zdbtc(klev+1) =0.0_rb
- ztrac(klev+1) =0.0_rb
- ztradc(klev+1)=0.0_rb
- zrefc(klev+1) =palbp(ibm)
- zrefdc(klev+1)=palbd(ibm)
- zrupc(klev+1) =palbp(ibm)
- zrupdc(klev+1)=palbd(ibm)
-
-! Total sky
-! TOA direct beam
- ztdbt(1)=1.0_rb
- ztdbt_nodel(1)=1.0_rb
-! Surface values
- zdbt(klev+1) =0.0_rb
- ztra(klev+1) =0.0_rb
- ztrad(klev+1)=0.0_rb
- zref(klev+1) =palbp(ibm)
- zrefd(klev+1)=palbd(ibm)
- zrup(klev+1) =palbp(ibm)
- zrupd(klev+1)=palbd(ibm)
-
-! Top of layer loop
- do jk=1,klev
-
-! Note: two-stream calculations proceed from top to bottom;
-! RRTMG_SW quantities are given bottom to top and are reversed here
-
- ikl=klev+1-jk
-
-! Set logical flag to do REFTRA calculation
-! Do REFTRA for all clear layers
- lrtchkclr(jk)=.true.
-
-! Do REFTRA only for cloudy layers in profile, since already done for clear layers
- lrtchkcld(jk)=.false.
- lrtchkcld(jk)=(pcldfmc(ikl,iw) > repclc)
-
-! Clear-sky optical parameters - this section inactive
-! Original
-! ztauc(jk) = ztaur(ikl,iw) + ztaug(ikl,iw)
-! zomcc(jk) = ztaur(ikl,iw) / ztauc(jk)
-! zgcc(jk) = 0.0001_rb
-! Total sky optical parameters
-! ztauo(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) + ptaucmc(ikl,iw)
-! zomco(jk) = ptaucmc(ikl,iw) * pomgcmc(ikl,iw) + ztaur(ikl,iw)
-! zgco (jk) = (ptaucmc(ikl,iw) * pomgcmc(ikl,iw) * pasycmc(ikl,iw) + &
-! ztaur(ikl,iw) * 0.0001_rb) / zomco(jk)
-! zomco(jk) = zomco(jk) / ztauo(jk)
-
-! Clear-sky optical parameters including aerosols
- ztauc(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) + ptaua(ikl,ibm)
- zomcc(jk) = ztaur(ikl,iw) * 1.0_rb + ptaua(ikl,ibm) * pomga(ikl,ibm)
- zgcc(jk) = pasya(ikl,ibm) * pomga(ikl,ibm) * ptaua(ikl,ibm) / zomcc(jk)
- zomcc(jk) = zomcc(jk) / ztauc(jk)
-
-! Pre-delta-scaling clear and cloudy direct beam transmittance (must use 'orig', unscaled cloud OD)
-! \/\/\/ This block of code is only needed for direct beam calculation
-!
- zclear = 1.0_rb - pcldfmc(ikl,iw)
- zcloud = pcldfmc(ikl,iw)
-
-! Clear
-! zdbtmc = exp(-ztauc(jk) / prmu0)
-
-! Use exponential lookup table for transmittance, or expansion of
-! exponential for low tau
- ze1 = ztauc(jk) / prmu0
- if (ze1 .le. od_lo) then
- zdbtmc = 1._rb - ze1 + 0.5_rb * ze1 * ze1
- else
- tblind = ze1 / (bpade + ze1)
- itind = tblint * tblind + 0.5_rb
- zdbtmc = exp_tbl(itind)
- endif
-
- zdbtc_nodel(jk) = zdbtmc
- ztdbtc_nodel(jk+1) = zdbtc_nodel(jk) * ztdbtc_nodel(jk)
-
-! Clear + Cloud
- tauorig = ztauc(jk) + ptaormc(ikl,iw)
-! zdbtmo = exp(-tauorig / prmu0)
-
-! Use exponential lookup table for transmittance, or expansion of
-! exponential for low tau
- ze1 = tauorig / prmu0
- if (ze1 .le. od_lo) then
- zdbtmo = 1._rb - ze1 + 0.5_rb * ze1 * ze1
- else
- tblind = ze1 / (bpade + ze1)
- itind = tblint * tblind + 0.5_rb
- zdbtmo = exp_tbl(itind)
- endif
-
- zdbt_nodel(jk) = zclear*zdbtmc + zcloud*zdbtmo
- ztdbt_nodel(jk+1) = zdbt_nodel(jk) * ztdbt_nodel(jk)
-! /\/\/\ Above code only needed for direct beam calculation
-
-
-! Delta scaling - clear
- zf = zgcc(jk) * zgcc(jk)
- zwf = zomcc(jk) * zf
- ztauc(jk) = (1.0_rb - zwf) * ztauc(jk)
- zomcc(jk) = (zomcc(jk) - zwf) / (1.0_rb - zwf)
- zgcc (jk) = (zgcc(jk) - zf) / (1.0_rb - zf)
-
-
-! Total sky optical parameters (cloud properties already delta-scaled)
-! Use this code if cloud properties are derived in rrtmg_sw_cldprop
- if (icpr .ge. 1) then
- ztauo(jk) = ztauc(jk) + ptaucmc(ikl,iw)
- zomco(jk) = ztauc(jk) * zomcc(jk) + ptaucmc(ikl,iw) * pomgcmc(ikl,iw)
- zgco (jk) = (ptaucmc(ikl,iw) * pomgcmc(ikl,iw) * pasycmc(ikl,iw) + &
- ztauc(jk) * zomcc(jk) * zgcc(jk)) / zomco(jk)
- zomco(jk) = zomco(jk) / ztauo(jk)
-
-! Total sky optical parameters (if cloud properties not delta scaled)
-! Use this code if cloud properties are not derived in rrtmg_sw_cldprop
- elseif (icpr .eq. 0) then
- ztauo(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) + ptaua(ikl,ibm) + ptaucmc(ikl,iw)
- zomco(jk) = ptaua(ikl,ibm) * pomga(ikl,ibm) + ptaucmc(ikl,iw) * pomgcmc(ikl,iw) + &
- ztaur(ikl,iw) * 1.0_rb
- zgco (jk) = (ptaucmc(ikl,iw) * pomgcmc(ikl,iw) * pasycmc(ikl,iw) + &
- ptaua(ikl,ibm)*pomga(ikl,ibm)*pasya(ikl,ibm)) / zomco(jk)
- zomco(jk) = zomco(jk) / ztauo(jk)
-
-! Delta scaling - clouds
-! Use only if subroutine rrtmg_sw_cldprop is not used to get cloud properties and to apply delta scaling
- zf = zgco(jk) * zgco(jk)
- zwf = zomco(jk) * zf
- ztauo(jk) = (1._rb - zwf) * ztauo(jk)
- zomco(jk) = (zomco(jk) - zwf) / (1.0_rb - zwf)
- zgco (jk) = (zgco(jk) - zf) / (1.0_rb - zf)
- endif
-
-! End of layer loop
- enddo
-
-! Clear sky reflectivities
- call reftra_sw (klev, &
- lrtchkclr, zgcc, prmu0, ztauc, zomcc, &
- zrefc, zrefdc, ztrac, ztradc)
-
-! Total sky reflectivities
- call reftra_sw (klev, &
- lrtchkcld, zgco, prmu0, ztauo, zomco, &
- zrefo, zrefdo, ztrao, ztrado)
-
- do jk=1,klev
-
-! Combine clear and cloudy contributions for total sky
- ikl = klev+1-jk
- zclear = 1.0_rb - pcldfmc(ikl,iw)
- zcloud = pcldfmc(ikl,iw)
-
- zref(jk) = zclear*zrefc(jk) + zcloud*zrefo(jk)
- zrefd(jk)= zclear*zrefdc(jk) + zcloud*zrefdo(jk)
- ztra(jk) = zclear*ztrac(jk) + zcloud*ztrao(jk)
- ztrad(jk)= zclear*ztradc(jk) + zcloud*ztrado(jk)
-
-! Direct beam transmittance
-
-! Clear
-! zdbtmc = exp(-ztauc(jk) / prmu0)
-
-! Use exponential lookup table for transmittance, or expansion of
-! exponential for low tau
- ze1 = ztauc(jk) / prmu0
- if (ze1 .le. od_lo) then
- zdbtmc = 1._rb - ze1 + 0.5_rb * ze1 * ze1
- else
- tblind = ze1 / (bpade + ze1)
- itind = tblint * tblind + 0.5_rb
- zdbtmc = exp_tbl(itind)
- endif
-
- zdbtc(jk) = zdbtmc
- ztdbtc(jk+1) = zdbtc(jk)*ztdbtc(jk)
-
-! Clear + Cloud
-! zdbtmo = exp(-ztauo(jk) / prmu0)
-
-! Use exponential lookup table for transmittance, or expansion of
-! exponential for low tau
- ze1 = ztauo(jk) / prmu0
- if (ze1 .le. od_lo) then
- zdbtmo = 1._rb - ze1 + 0.5_rb * ze1 * ze1
- else
- tblind = ze1 / (bpade + ze1)
- itind = tblint * tblind + 0.5_rb
- zdbtmo = exp_tbl(itind)
- endif
-
- zdbt(jk) = zclear*zdbtmc + zcloud*zdbtmo
- ztdbt(jk+1) = zdbt(jk)*ztdbt(jk)
-
- enddo
-
-! Vertical quadrature for clear-sky fluxes
-
- call vrtqdr_sw(klev, iw, &
- zrefc, zrefdc, ztrac, ztradc, &
- zdbtc, zrdndc, zrupc, zrupdc, ztdbtc, &
- zcd, zcu)
-
-! Vertical quadrature for cloudy fluxes
-
- call vrtqdr_sw(klev, iw, &
- zref, zrefd, ztra, ztrad, &
- zdbt, zrdnd, zrup, zrupd, ztdbt, &
- zfd, zfu)
-
-! Upwelling and downwelling fluxes at levels
-! Two-stream calculations go from top to bottom;
-! layer indexing is reversed to go bottom to top for output arrays
-
- do jk=1,klev+1
- ikl=klev+2-jk
-
-! Accumulate spectral fluxes over bands - inactive
-! zbbfu(ikl) = zbbfu(ikl) + zincflx(iw)*zfu(jk,iw)
-! zbbfd(ikl) = zbbfd(ikl) + zincflx(iw)*zfd(jk,iw)
-! zbbcu(ikl) = zbbcu(ikl) + zincflx(iw)*zcu(jk,iw)
-! zbbcd(ikl) = zbbcd(ikl) + zincflx(iw)*zcd(jk,iw)
-! zbbfddir(ikl) = zbbfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk)
-! zbbcddir(ikl) = zbbcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk)
-
-! Accumulate spectral fluxes over whole spectrum
- pbbfu(ikl) = pbbfu(ikl) + zincflx(iw)*zfu(jk,iw)
- pbbfd(ikl) = pbbfd(ikl) + zincflx(iw)*zfd(jk,iw)
- pbbcu(ikl) = pbbcu(ikl) + zincflx(iw)*zcu(jk,iw)
- pbbcd(ikl) = pbbcd(ikl) + zincflx(iw)*zcd(jk,iw)
- pbbfddir(ikl) = pbbfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk)
- pbbcddir(ikl) = pbbcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk)
-
-! Accumulate direct fluxes for UV/visible bands
- if (ibm >= 10 .and. ibm <= 13) then
- puvcd(ikl) = puvcd(ikl) + zincflx(iw)*zcd(jk,iw)
- puvfd(ikl) = puvfd(ikl) + zincflx(iw)*zfd(jk,iw)
- puvcddir(ikl) = puvcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk)
- puvfddir(ikl) = puvfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk)
-! Accumulate direct fluxes for near-IR bands
- else if (ibm == 14 .or. ibm <= 9) then
- pnicd(ikl) = pnicd(ikl) + zincflx(iw)*zcd(jk,iw)
- pnifd(ikl) = pnifd(ikl) + zincflx(iw)*zfd(jk,iw)
- pnicddir(ikl) = pnicddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk)
- pnifddir(ikl) = pnifddir(ikl) + zincflx(iw)*ztdbt_nodel(jk)
- endif
-
- enddo
-
-! End loop on jg, g-point interval
- enddo
-
-! End loop on jb, spectral band
- enddo
-
- end subroutine spcvmc_sw
-
- end module rrtmg_sw_spcvmc
-
-! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
-! author: $Author: trn $
-! revision: $Revision: 1.3 $
-! created: $Date: 2009/04/16 19:54:22 $
-!
- module rrtmg_sw_rad
-
-! --------------------------------------------------------------------------
-! | |
-! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
-! | This software may be used, copied, or redistributed as long as it is |
-! | not sold and this copyright notice is reproduced on each copy made. |
-! | This model is provided as is without any express or implied warranties. |
-! | (http://www.rtweb.aer.com/) |
-! | |
-! --------------------------------------------------------------------------
-!
-! ****************************************************************************
-! * *
-! * RRTMG_SW *
-! * *
-! * *
-! * *
-! * a rapid radiative transfer model *
-! * for the solar spectral region *
-! * for application to general circulation models *
-! * *
-! * *
-! * Atmospheric and Environmental Research, Inc. *
-! * 131 Hartwell Avenue *
-! * Lexington, MA 02421 *
-! * *
-! * *
-! * Eli J. Mlawer *
-! * Jennifer S. Delamere *
-! * Michael J. Iacono *
-! * Shepard A. Clough *
-! * *
-! * *
-! * *
-! * *
-! * *
-! * *
-! * email: miacono@aer.com *
-! * email: emlawer@aer.com *
-! * email: jdelamer@aer.com *
-! * *
-! * The authors wish to acknowledge the contributions of the *
-! * following people: Steven J. Taubman, Patrick D. Brown, *
-! * Ronald E. Farren, Luke Chen, Robert Bergstrom. *
-! * *
-! ****************************************************************************
-
-! --------- Modules ---------
-
- use parkind, only : im => kind_im, rb => kind_rb
- use rrsw_vsn
- use mcica_subcol_gen_sw, only: mcica_subcol_sw
- use rrtmg_sw_cldprmc, only: cldprmc_sw
-! *** Move the required call to rrtmg_sw_ini below and the following
-! use association to GCM initialization area ***
-! use rrtmg_sw_init, only: rrtmg_sw_ini
- use rrtmg_sw_setcoef, only: setcoef_sw
- use rrtmg_sw_spcvmc, only: spcvmc_sw
-
- implicit none
-
-! public interfaces/functions/subroutines
- public :: rrtmg_sw, inatm_sw, earth_sun
-
-!------------------------------------------------------------------
- contains
-!------------------------------------------------------------------
-
-!------------------------------------------------------------------
-! Public subroutines
-!------------------------------------------------------------------
-
- subroutine rrtmg_sw &
- (ncol ,nlay ,icld , &
- play ,plev ,tlay ,tlev ,tsfc , &
- h2ovmr , o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , &
- asdir ,asdif ,aldir ,aldif , &
- coszen ,adjes ,dyofyr ,scon , &
- inflgsw ,iceflgsw,liqflgsw,cldfmcl , &
- taucmcl ,ssacmcl ,asmcmcl ,fsfcmcl , &
- ciwpmcl ,clwpmcl ,cswpmcl ,reicmcl ,relqmcl ,resnmcl, &
- tauaer ,ssaaer ,asmaer ,ecaer , &
- swuflx ,swdflx ,swhr ,swuflxc ,swdflxc ,swhrc, swuflxcln ,swdflxcln , aer_opt, &
-! --------- Add the following four compenants for ssib shortwave down radiation ---!
-! ------------------- by Zhenxin 2011-06-20 --------------------------------!
- sibvisdir, sibvisdif, sibnirdir, sibnirdif, &
-! ---------------------- End, Zhenxin 2011-06-20 --------------------------------!
- swdkdir,swdkdif, & ! jararias, 2013/08/10
- swdkdirc & ! PAJ
- ,calc_clean_atm_diag &
- ,sw_zbbcddir, sw_dirdflux, sw_difdflux & ! WRF-CMAQ twoway coupled model
- )
-
-
-! ------- Description -------
-
-! This program is the driver for RRTMG_SW, the AER SW radiation model for
-! application to GCMs, that has been adapted from RRTM_SW for improved
-! efficiency and to provide fractional cloudiness and cloud overlap
-! capability using McICA.
-!
-! Note: The call to RRTMG_SW_INI should be moved to the GCM initialization
-! area, since this has to be called only once.
-!
-! This routine
-! b) calls INATM_SW to read in the atmospheric profile;
-! all layering in RRTMG is ordered from surface to toa.
-! c) calls CLDPRMC_SW to set cloud optical depth for McICA based
-! on input cloud properties
-! d) calls SETCOEF_SW to calculate various quantities needed for
-! the radiative transfer algorithm
-! e) calls SPCVMC to call the two-stream model that in turn
-! calls TAUMOL to calculate gaseous optical depths for each
-! of the 16 spectral bands and to perform the radiative transfer
-! using McICA, the Monte-Carlo Independent Column Approximation,
-! to represent sub-grid scale cloud variability
-! f) passes the calculated fluxes and cooling rates back to GCM
-!
-! Two modes of operation are possible:
-! The mode is chosen by using either rrtmg_sw.nomcica.f90 (to not use
-! McICA) or rrtmg_sw.f90 (to use McICA) to interface with a GCM.
-!
-! 1) Standard, single forward model calculation (imca = 0); this is
-! valid only for clear sky or fully overcast clouds
-! 2) Monte Carlo Independent Column Approximation (McICA, Pincus et al.,
-! JC, 2003) method is applied to the forward model calculation (imca = 1)
-! This method is valid for clear sky or partial cloud conditions.
-!
-! This call to RRTMG_SW must be preceeded by a call to the module
-! mcica_subcol_gen_sw.f90 to run the McICA sub-column cloud generator,
-! which will provide the cloud physical or cloud optical properties
-! on the RRTMG quadrature point (ngptsw) dimension.
-!
-! Two methods of cloud property input are possible:
-! Cloud properties can be input in one of two ways (controlled by input
-! flags inflag, iceflag and liqflag; see text file rrtmg_sw_instructions
-! and subroutine rrtmg_sw_cldprop.f90 for further details):
-!
-! 1) Input cloud fraction, cloud optical depth, single scattering albedo
-! and asymmetry parameter directly (inflgsw = 0)
-! 2) Input cloud fraction and cloud physical properties: ice fracion,
-! ice and liquid particle sizes (inflgsw = 1 or 2);
-! cloud optical properties are calculated by cldprop or cldprmc based
-! on input settings of iceflgsw and liqflgsw
-!
-! Two methods of aerosol property input are possible:
-! Aerosol properties can be input in one of two ways (controlled by input
-! flag iaer, see text file rrtmg_sw_instructions for further details):
-!
-! 1) Input aerosol optical depth, single scattering albedo and asymmetry
-! parameter directly by layer and spectral band (iaer=10)
-! 2) Input aerosol optical depth and 0.55 micron directly by layer and use
-! one or more of six ECMWF aerosol types (iaer=6)
-!
-!
-! ------- Modifications -------
-!
-! This version of RRTMG_SW has been modified from RRTM_SW to use a reduced
-! set of g-point intervals and a two-stream model for application to GCMs.
-!
-!-- Original version (derived from RRTM_SW)
-! 2002: AER. Inc.
-!-- Conversion to F90 formatting; addition of 2-stream radiative transfer
-! Feb 2003: J.-J. Morcrette, ECMWF
-!-- Additional modifications for GCM application
-! Aug 2003: M. J. Iacono, AER Inc.
-!-- Total number of g-points reduced from 224 to 112. Original
-! set of 224 can be restored by exchanging code in module parrrsw.f90
-! and in file rrtmg_sw_init.f90.
-! Apr 2004: M. J. Iacono, AER, Inc.
-!-- Modifications to include output for direct and diffuse
-! downward fluxes. There are output as "true" fluxes without
-! any delta scaling applied. Code can be commented to exclude
-! this calculation in source file rrtmg_sw_spcvrt.f90.
-! Jan 2005: E. J. Mlawer, M. J. Iacono, AER, Inc.
-!-- Revised to add McICA capability.
-! Nov 2005: M. J. Iacono, AER, Inc.
-!-- Reformatted for consistency with rrtmg_lw.
-! Feb 2007: M. J. Iacono, AER, Inc.
-!-- Modifications to formatting to use assumed-shape arrays.
-! Aug 2007: M. J. Iacono, AER, Inc.
-
-! --------- Modules ---------
-
- use parrrsw, only : nbndsw, ngptsw, naerec, nstr, nmol, mxmol, &
- jpband, jpb1, jpb2
- use rrsw_aer, only : rsrtaua, rsrpiza, rsrasya
- use rrsw_con, only : heatfac, oneminus, pi
- use rrsw_wvn, only : wavenum1, wavenum2
-
-! ------- Declarations
-
-! ----- Input -----
-
- integer(kind=im), intent(in) :: ncol ! Number of horizontal columns
- integer(kind=im), intent(in) :: nlay ! Number of model layers
- integer(kind=im), intent(inout) :: icld ! Cloud overlap method
- ! 0: Clear only
- ! 1: Random
- ! 2: Maximum/random
- ! 3: Maximum
- ! 4: Exponential
- ! 5: Exponential/random
- real(kind=rb), intent(in) :: play(:,:) ! Layer pressures (hPa, mb)
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: plev(:,:) ! Interface pressures (hPa, mb)
- ! Dimensions: (ncol,nlay+1)
- real(kind=rb), intent(in) :: tlay(:,:) ! Layer temperatures (K)
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: tlev(:,:) ! Interface temperatures (K)
- ! Dimensions: (ncol,nlay+1)
- real(kind=rb), intent(in) :: tsfc(:) ! Surface temperature (K)
- ! Dimensions: (ncol)
- real(kind=rb), intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: o2vmr(:,:) ! Oxygen volume mixing ratio
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: asdir(:) ! UV/vis surface albedo direct rad
- ! Dimensions: (ncol)
- real(kind=rb), intent(in) :: aldir(:) ! Near-IR surface albedo direct rad
- ! Dimensions: (ncol)
- real(kind=rb), intent(in) :: asdif(:) ! UV/vis surface albedo: diffuse rad
- ! Dimensions: (ncol)
- real(kind=rb), intent(in) :: aldif(:) ! Near-IR surface albedo: diffuse rad
- ! Dimensions: (ncol)
-
- integer(kind=im), intent(in) :: dyofyr ! Day of the year (used to get Earth/Sun
- ! distance if adjflx not provided)
- real(kind=rb), intent(in) :: adjes ! Flux adjustment for Earth/Sun distance
- real(kind=rb), intent(in) :: coszen(:) ! Cosine of solar zenith angle
- ! Dimensions: (ncol)
- real(kind=rb), intent(in) :: scon ! Solar constant (W/m2)
-
- integer(kind=im), intent(in) :: inflgsw ! Flag for cloud optical properties
- integer(kind=im), intent(in) :: iceflgsw ! Flag for ice particle specification
- integer(kind=im), intent(in) :: liqflgsw ! Flag for liquid droplet specification
-
- real(kind=rb), intent(in) :: cldfmcl(:,:,:) ! Cloud fraction
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(in) :: taucmcl(:,:,:) ! In-cloud optical depth
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(in) :: ssacmcl(:,:,:) ! In-cloud single scattering albedo
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(in) :: asmcmcl(:,:,:) ! In-cloud asymmetry parameter
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(in) :: fsfcmcl(:,:,:) ! In-cloud forward scattering fraction
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(in) :: ciwpmcl(:,:,:) ! In-cloud ice water path (g/m2)
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(in) :: clwpmcl(:,:,:) ! In-cloud liquid water path (g/m2)
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(in) :: cswpmcl(:,:,:) ! In-cloud snow water path (g/m2)
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(in) :: reicmcl(:,:) ! Cloud ice effective radius (microns)
- ! Dimensions: (ncol,nlay)
- ! specific definition of reicmcl depends on setting of iceflglw:
- ! iceflglw = 0: ice effective radius, r_ec, (Ebert and Curry, 1992),
- ! r_ec must be >= 10.0 microns
- ! iceflglw = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
- ! r_ec range is limited to 13.0 to 130.0 microns
- ! iceflglw = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
- ! r_k range is limited to 5.0 to 131.0 microns
- ! iceflglw = 3: generalized effective size, dge, (Fu, 1996),
- ! dge range is limited to 5.0 to 140.0 microns
- ! [dge = 1.0315 * r_ec]
- real(kind=rb), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns)
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: resnmcl(:,:) ! Cloud snow effective radius (microns)
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: tauaer(:,:,:) ! Aerosol optical depth (iaer=10 only)
- ! Dimensions: (ncol,nlay,nbndsw)
- ! (non-delta scaled)
- real(kind=rb), intent(in) :: ssaaer(:,:,:) ! Aerosol single scattering albedo (iaer=10 only)
- ! Dimensions: (ncol,nlay,nbndsw)
- ! (non-delta scaled)
- real(kind=rb), intent(in) :: asmaer(:,:,:) ! Aerosol asymmetry parameter (iaer=10 only)
- ! Dimensions: (ncol,nlay,nbndsw)
- ! (non-delta scaled)
- real(kind=rb), intent(in) :: ecaer(:,:,:) ! Aerosol optical depth at 0.55 micron (iaer=6 only)
- ! Dimensions: (ncol,nlay,naerec)
- ! (non-delta scaled)
- integer, intent(in) :: calc_clean_atm_diag! Control for clean air diagnositic calls for WRF-Chem
-
-! ----- Output -----
-
- real(kind=rb), intent(out) :: swuflx(:,:) ! Total sky shortwave upward flux (W/m2)
- ! Dimensions: (ncol,nlay+1)
- real(kind=rb), intent(out) :: swdflx(:,:) ! Total sky shortwave downward flux (W/m2)
- ! Dimensions: (ncol,nlay+1)
- real(kind=rb), intent(out) :: sibvisdir(:,:) ! visible direct downward flux (W/m2)
- ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
- real(kind=rb), intent(out) :: sibvisdif(:,:) ! visible diffusion downward flux (W/m2)
- ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
- real(kind=rb), intent(out) :: sibnirdir(:,:) ! Near IR direct downward flux (W/m2)
- ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
- real(kind=rb), intent(out) :: sibnirdif(:,:) ! Near IR diffusion downward flux (W/m2)
- ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
- real(kind=rb), intent(out) :: swhr(:,:) ! Total sky shortwave radiative heating rate (K/d)
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(out) :: swuflxc(:,:) ! Clear sky shortwave upward flux (W/m2)
- ! Dimensions: (ncol,nlay+1)
- real(kind=rb), intent(out) :: swdflxc(:,:) ! Clear sky shortwave downward flux (W/m2)
- ! Dimensions: (ncol,nlay+1)
- real(kind=rb), intent(out) :: swhrc(:,:) ! Clear sky shortwave radiative heating rate (K/d)
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(out) :: swuflxcln(:,:) ! Clean sky shortwave upward flux (W/m2)
- ! Dimensions: (ncol,nlay+1)
- real(kind=rb), intent(out) :: swdflxcln(:,:) ! Clean sky shortwave downward flux (W/m2)
- ! Dimensions: (ncol,nlay+1)
-
- integer, intent(in) :: aer_opt
- real(kind=rb), intent(out) :: &
- swdkdir(:,:), & ! Total shortwave downward direct flux (W/m2), Dimensions: (ncol,nlay) jararias, 2013/08/10
- swdkdif(:,:), & ! Total shortwave downward diffuse flux (W/m2), Dimensions: (ncol,nlay) jararias, 2013/08/10
- swdkdirc(:,:) ! Total shortwave downward direct flux clear sky (W/m2), Dimensions: (ncol,nlay)
-
- real, intent(out) :: sw_zbbcddir, & ! WRF-CMAQ twoway coupled model
- sw_dirdflux, & ! WRF-CMAQ twoway coupled model
- sw_difdflux ! WRF-CMAQ twoway coupled model
-
-
-
-! ----- Local -----
-
-! Control
- integer(kind=im) :: nlayers ! total number of layers
- integer(kind=im) :: istart ! beginning band of calculation
- integer(kind=im) :: iend ! ending band of calculation
- integer(kind=im) :: icpr ! cldprop/cldprmc use flag
- integer(kind=im) :: iout ! output option flag (inactive)
- integer(kind=im) :: iaer ! aerosol option flag
- integer(kind=im) :: idelm ! delta-m scaling flag (inactive)
- integer(kind=im) :: isccos ! instrumental cosine response flag (inactive)
- integer(kind=im) :: iplon ! column loop index
- integer(kind=im) :: i ! layer loop index ! jk
- integer(kind=im) :: ib ! band loop index ! jsw
- integer(kind=im) :: ia, ig ! indices
- integer(kind=im) :: k ! layer loop index
- integer(kind=im) :: ims ! value for changing mcica permute seed
- integer(kind=im) :: imca ! flag for mcica [0=off, 1=on]
-
- real(kind=rb) :: zepsec, zepzen ! epsilon
- real(kind=rb) :: zdpgcp ! flux to heating conversion ratio
-
-! Atmosphere
- real(kind=rb) :: pavel(nlay+1) ! layer pressures (mb)
- real(kind=rb) :: tavel(nlay+1) ! layer temperatures (K)
- real(kind=rb) :: pz(0:nlay+1) ! level (interface) pressures (hPa, mb)
- real(kind=rb) :: tz(0:nlay+1) ! level (interface) temperatures (K)
- real(kind=rb) :: tbound ! surface temperature (K)
- real(kind=rb) :: pdp(nlay+1) ! layer pressure thickness (hPa, mb)
- real(kind=rb) :: coldry(nlay+1) ! dry air column amount
- real(kind=rb) :: wkl(mxmol,nlay+1) ! molecular amounts (mol/cm-2)
-
-! real(kind=rb) :: earth_sun ! function for Earth/Sun distance factor
- real(kind=rb) :: cossza ! Cosine of solar zenith angle
- real(kind=rb) :: adjflux(jpband) ! adjustment for current Earth/Sun distance
- real(kind=rb) :: solvar(jpband) ! solar constant scaling factor from rrtmg_sw
- ! default value of 1368.22 Wm-2 at 1 AU
- real(kind=rb) :: albdir(nbndsw) ! surface albedo, direct ! zalbp
- real(kind=rb) :: albdif(nbndsw) ! surface albedo, diffuse ! zalbd
-
- real(kind=rb) :: taua(nlay+1,nbndsw) ! Aerosol optical depth
- real(kind=rb) :: ssaa(nlay+1,nbndsw) ! Aerosol single scattering albedo
- real(kind=rb) :: asma(nlay+1,nbndsw) ! Aerosol asymmetry parameter
-
-! Atmosphere - setcoef
- integer(kind=im) :: laytrop ! tropopause layer index
- integer(kind=im) :: layswtch ! tropopause layer index
- integer(kind=im) :: laylow ! tropopause layer index
- integer(kind=im) :: jp(nlay+1) !
- integer(kind=im) :: jt(nlay+1) !
- integer(kind=im) :: jt1(nlay+1) !
-
- real(kind=rb) :: colh2o(nlay+1) ! column amount (h2o)
- real(kind=rb) :: colco2(nlay+1) ! column amount (co2)
- real(kind=rb) :: colo3(nlay+1) ! column amount (o3)
- real(kind=rb) :: coln2o(nlay+1) ! column amount (n2o)
- real(kind=rb) :: colch4(nlay+1) ! column amount (ch4)
- real(kind=rb) :: colo2(nlay+1) ! column amount (o2)
- real(kind=rb) :: colmol(nlay+1) ! column amount
- real(kind=rb) :: co2mult(nlay+1) ! column amount
-
- integer(kind=im) :: indself(nlay+1)
- integer(kind=im) :: indfor(nlay+1)
- real(kind=rb) :: selffac(nlay+1)
- real(kind=rb) :: selffrac(nlay+1)
- real(kind=rb) :: forfac(nlay+1)
- real(kind=rb) :: forfrac(nlay+1)
-
- real(kind=rb) :: & !
- fac00(nlay+1), fac01(nlay+1), &
- fac10(nlay+1), fac11(nlay+1)
-
-! Atmosphere/clouds - cldprop
- integer(kind=im) :: ncbands ! number of cloud spectral bands
- integer(kind=im) :: inflag ! flag for cloud property method
- integer(kind=im) :: iceflag ! flag for ice cloud properties
- integer(kind=im) :: liqflag ! flag for liquid cloud properties
-
-! real(kind=rb) :: cldfrac(nlay+1) ! layer cloud fraction
-! real(kind=rb) :: tauc(nlay+1) ! in-cloud optical depth (non-delta scaled)
-! real(kind=rb) :: ssac(nlay+1) ! in-cloud single scattering albedo (non-delta scaled)
-! real(kind=rb) :: asmc(nlay+1) ! in-cloud asymmetry parameter (non-delta scaled)
-! real(kind=rb) :: fsfc(nlay+1) ! in-cloud forward scattering fraction (non-delta scaled)
-! real(kind=rb) :: ciwp(nlay+1) ! in-cloud ice water path
-! real(kind=rb) :: clwp(nlay+1) ! in-cloud liquid water path
-! real(kind=rb) :: rei(nlay+1) ! cloud ice particle size
-! real(kind=rb) :: rel(nlay+1) ! cloud liquid particle size
-
-! real(kind=rb) :: taucloud(nlay+1,jpband) ! in-cloud optical depth
-! real(kind=rb) :: taucldorig(nlay+1,jpband)! in-cloud optical depth (non-delta scaled)
-! real(kind=rb) :: ssacloud(nlay+1,jpband) ! in-cloud single scattering albedo
-! real(kind=rb) :: asmcloud(nlay+1,jpband) ! in-cloud asymmetry parameter
-
-! Atmosphere/clouds - cldprmc [mcica]
- real(kind=rb) :: cldfmc(ngptsw,nlay+1) ! cloud fraction [mcica]
- real(kind=rb) :: ciwpmc(ngptsw,nlay+1) ! in-cloud ice water path [mcica]
- real(kind=rb) :: clwpmc(ngptsw,nlay+1) ! in-cloud liquid water path [mcica]
- real(kind=rb) :: cswpmc(ngptsw,nlay+1) ! in-cloud snow water path [mcica]
- real(kind=rb) :: relqmc(nlay+1) ! liquid particle effective radius (microns)
- real(kind=rb) :: reicmc(nlay+1) ! ice particle effective size (microns)
- real(kind=rb) :: resnmc(nlay+1) ! snow particle effective size (microns)
- real(kind=rb) :: taucmc(ngptsw,nlay+1) ! in-cloud optical depth [mcica]
- real(kind=rb) :: taormc(ngptsw,nlay+1) ! unscaled in-cloud optical depth [mcica]
- real(kind=rb) :: ssacmc(ngptsw,nlay+1) ! in-cloud single scattering albedo [mcica]
- real(kind=rb) :: asmcmc(ngptsw,nlay+1) ! in-cloud asymmetry parameter [mcica]
- real(kind=rb) :: fsfcmc(ngptsw,nlay+1) ! in-cloud forward scattering fraction [mcica]
-
-! Atmosphere/clouds/aerosol - spcvrt,spcvmc
- real(kind=rb) :: ztauc(nlay+1,nbndsw) ! cloud optical depth
- real(kind=rb) :: ztaucorig(nlay+1,nbndsw) ! unscaled cloud optical depth
- real(kind=rb) :: zasyc(nlay+1,nbndsw) ! cloud asymmetry parameter
- ! (first moment of phase function)
- real(kind=rb) :: zomgc(nlay+1,nbndsw) ! cloud single scattering albedo
- real(kind=rb) :: ztaua(nlay+1,nbndsw) ! total aerosol optical depth
- real(kind=rb) :: ztauacln(nlay+1,nbndsw) ! dummy total aerosol optical depth for clean case (=zero)
- real(kind=rb) :: zasya(nlay+1,nbndsw) ! total aerosol asymmetry parameter
- real(kind=rb) :: zomga(nlay+1,nbndsw) ! total aerosol single scattering albedo
-
- real(kind=rb) :: zcldfmc(nlay+1,ngptsw) ! cloud fraction [mcica]
- real(kind=rb) :: ztaucmc(nlay+1,ngptsw) ! cloud optical depth [mcica]
- real(kind=rb) :: ztaormc(nlay+1,ngptsw) ! unscaled cloud optical depth [mcica]
- real(kind=rb) :: zasycmc(nlay+1,ngptsw) ! cloud asymmetry parameter [mcica]
- real(kind=rb) :: zomgcmc(nlay+1,ngptsw) ! cloud single scattering albedo [mcica]
-
- real(kind=rb) :: zbbfu(nlay+2) ! temporary upward shortwave flux (w/m2)
- real(kind=rb) :: zbbfd(nlay+2) ! temporary downward shortwave flux (w/m2)
- real(kind=rb) :: zbbcu(nlay+2) ! temporary clear sky upward shortwave flux (w/m2)
- real(kind=rb) :: zbbcd(nlay+2) ! temporary clear sky downward shortwave flux (w/m2)
- real(kind=rb) :: zbbfddir(nlay+2) ! temporary downward direct shortwave flux (w/m2)
- real(kind=rb) :: zbbcddir(nlay+2) ! temporary clear sky downward direct shortwave flux (w/m2)
- real(kind=rb) :: zuvfd(nlay+2) ! temporary UV downward shortwave flux (w/m2)
- real(kind=rb) :: zuvcd(nlay+2) ! temporary clear sky UV downward shortwave flux (w/m2)
- real(kind=rb) :: zuvfddir(nlay+2) ! temporary UV downward direct shortwave flux (w/m2)
- real(kind=rb) :: zuvcddir(nlay+2) ! temporary clear sky UV downward direct shortwave flux (w/m2)
- real(kind=rb) :: znifd(nlay+2) ! temporary near-IR downward shortwave flux (w/m2)
- real(kind=rb) :: znicd(nlay+2) ! temporary clear sky near-IR downward shortwave flux (w/m2)
- real(kind=rb) :: znifddir(nlay+2) ! temporary near-IR downward direct shortwave flux (w/m2)
- real(kind=rb) :: znicddir(nlay+2) ! temporary clear sky near-IR downward direct shortwave flux (w/m2)
- real(kind=rb) :: zbbclnu(nlay+2) ! temporary clean sky upward shortwave flux (w/m2)
- real(kind=rb) :: zbbclnd(nlay+2) ! temporary clean sky downward shortwave flux (w/m2)
- real(kind=rb) :: zbbclnddir(nlay+2) ! temporary clean sky downward direct shortwave flux (w/m2)
- real(kind=rb) :: zuvclnd(nlay+2) ! temporary clean sky UV downward shortwave flux (w/m2)
- real(kind=rb) :: zuvclnddir(nlay+2) ! temporary clean sky UV downward direct shortwave flux (w/m2)
- real(kind=rb) :: zniclnd(nlay+2) ! temporary clean sky near-IR downward shortwave flux (w/m2)
- real(kind=rb) :: zniclnddir(nlay+2) ! temporary clean sky near-IR downward direct shortwave flux (w/m2)
-
-! Optional output fields
- real(kind=rb) :: swnflx(nlay+2) ! Total sky shortwave net flux (W/m2)
- real(kind=rb) :: swnflxc(nlay+2) ! Clear sky shortwave net flux (W/m2)
- real(kind=rb) :: dirdflux(nlay+2) ! Direct downward shortwave surface flux
- real(kind=rb) :: difdflux(nlay+2) ! Diffuse downward shortwave surface flux
- real(kind=rb) :: uvdflx(nlay+2) ! Total sky downward shortwave flux, UV/vis
- real(kind=rb) :: nidflx(nlay+2) ! Total sky downward shortwave flux, near-IR
- real(kind=rb) :: dirdnuv(nlay+2) ! Direct downward shortwave flux, UV/vis
- real(kind=rb) :: difdnuv(nlay+2) ! Diffuse downward shortwave flux, UV/vis
- real(kind=rb) :: dirdnir(nlay+2) ! Direct downward shortwave flux, near-IR
- real(kind=rb) :: difdnir(nlay+2) ! Diffuse downward shortwave flux, near-IR
-
-! Output - inactive
-! real(kind=rb) :: zuvfu(nlay+2) ! temporary upward UV shortwave flux (w/m2)
-! real(kind=rb) :: zuvfd(nlay+2) ! temporary downward UV shortwave flux (w/m2)
-! real(kind=rb) :: zuvcu(nlay+2) ! temporary clear sky upward UV shortwave flux (w/m2)
-! real(kind=rb) :: zuvcd(nlay+2) ! temporary clear sky downward UV shortwave flux (w/m2)
-! real(kind=rb) :: zvsfu(nlay+2) ! temporary upward visible shortwave flux (w/m2)
-! real(kind=rb) :: zvsfd(nlay+2) ! temporary downward visible shortwave flux (w/m2)
-! real(kind=rb) :: zvscu(nlay+2) ! temporary clear sky upward visible shortwave flux (w/m2)
-! real(kind=rb) :: zvscd(nlay+2) ! temporary clear sky downward visible shortwave flux (w/m2)
-! real(kind=rb) :: znifu(nlay+2) ! temporary upward near-IR shortwave flux (w/m2)
-! real(kind=rb) :: znifd(nlay+2) ! temporary downward near-IR shortwave flux (w/m2)
-! real(kind=rb) :: znicu(nlay+2) ! temporary clear sky upward near-IR shortwave flux (w/m2)
-! real(kind=rb) :: znicd(nlay+2) ! temporary clear sky downward near-IR shortwave flux (w/m2)
-
-
-! Initializations
-
- iout = 0 !BSINGH(PNNL) initializing iout to zero(Might be wrong!) as this variable is never initialized but used in spcvmc_sw
- zepsec = 1.e-06_rb
- zepzen = 1.e-10_rb
-!jm not thread safe oneminus = 1.0_rb - zepsec
-!jm not thread safe pi = 2._rb * asin(1._rb)
-
- istart = jpb1
- iend = jpb2
- icpr = 0
- ims = 2
-
-! In a GCM with or without McICA, set nlon to the longitude dimension
-!
-! Set imca to select calculation type:
-! imca = 0, use standard forward model calculation (clear and overcast only)
-! imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability
-! (clear, overcast or partial cloud conditions)
-
-! *** This version uses McICA (imca = 1) ***
-
-! Set icld to select of clear or cloud calculation and cloud
-! overlap method (read by subroutine readprof from input file INPUT_RRTM):
-! icld = 0, clear only
-! icld = 1, with clouds using random cloud overlap (McICA only)
-! icld = 2, with clouds using maximum/random cloud overlap (McICA only)
-! icld = 3, with clouds using maximum cloud overlap (McICA only)
-! icld = 4, with clouds using exponential cloud overlap (McICA only)
-! icld = 5, with clouds using exponential/random cloud overlap (McICA only)
-
-! Set iaer to select aerosol option
-! iaer = 0, no aerosols
-! iaer = 6, use six ECMWF aerosol types
-! input aerosol optical depth at 0.55 microns for each aerosol type (ecaer)
-! iaer = 10, input total aerosol optical depth, single scattering albedo
-! and asymmetry parameter (tauaer, ssaaer, asmaer) directly
- if ( aer_opt.eq.0 .or. aer_opt.eq.2 .or. aer_opt.eq.3) then
- iaer = 10
- else if ( aer_opt .eq. 1 ) then
- iaer = 6
- endif
-
-! Call model and data initialization, compute lookup tables, perform
-! reduction of g-points from 224 to 112 for input absorption
-! coefficient data and other arrays.
-!
-! In a GCM this call should be placed in the model initialization
-! area, since this has to be called only once.
-! call rrtmg_sw_ini(cpdair)
-
-! This is the main longitude/column loop in RRTMG.
-! Modify to loop over all columns (nlon) or over daylight columns
-
- do iplon = 1, ncol
-
-! Prepare atmosphere profile from GCM for use in RRTMG, and define
-! other input parameters
-
- call inatm_sw (iplon, nlay, icld, iaer, &
- play, plev, tlay, tlev, tsfc, h2ovmr, &
- o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, &
- adjes, dyofyr, scon, inflgsw, iceflgsw, liqflgsw, &
- cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl, ciwpmcl, clwpmcl, cswpmcl, &
- reicmcl, relqmcl, resnmcl, tauaer, ssaaer, asmaer, &
- nlayers, pavel, pz, pdp, tavel, tz, tbound, coldry, wkl, &
- adjflux, solvar, inflag, iceflag, liqflag, cldfmc, taucmc, &
- ssacmc, asmcmc, fsfcmc, ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, &
- taua, ssaa, asma)
-
-! For cloudy atmosphere, use cldprop to set cloud optical properties based on
-! input cloud physical properties. Select method based on choices described
-! in cldprop. Cloud fraction, water path, liquid droplet and ice particle
-! effective radius must be passed in cldprop. Cloud fraction and cloud
-! optical properties are transferred to rrtmg_sw arrays in cldprop.
-
- call cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, &
- ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, &
- taormc, taucmc, ssacmc, asmcmc, fsfcmc)
- icpr = 1
-
-! Calculate coefficients for the temperature and pressure dependence of the
-! molecular absorption coefficients by interpolating data from stored
-! reference atmospheres.
-
- call setcoef_sw(nlayers, pavel, tavel, pz, tz, tbound, coldry, wkl, &
- laytrop, layswtch, laylow, jp, jt, jt1, &
- co2mult, colch4, colco2, colh2o, colmol, coln2o, &
- colo2, colo3, fac00, fac01, fac10, fac11, &
- selffac, selffrac, indself, forfac, forfrac, indfor)
-
-
-! Cosine of the solar zenith angle
-! Prevent using value of zero; ideally, SW model is not called from host model when sun
-! is below horizon
-
- cossza = coszen(iplon)
- if (cossza .le. zepzen) cossza = zepzen
-
-! Transfer albedo, cloud and aerosol properties into arrays for 2-stream radiative transfer
-
-! Surface albedo
-! Near-IR bands 16-24 and 29 (1-9 and 14), 820-16000 cm-1, 0.625-12.195 microns
- do ib=1,9
- albdir(ib) = aldir(iplon)
- albdif(ib) = aldif(iplon)
- enddo
- albdir(nbndsw) = aldir(iplon)
- albdif(nbndsw) = aldif(iplon)
-! UV/visible bands 25-28 (10-13), 16000-50000 cm-1, 0.200-0.625 micron
- do ib=10,13
- albdir(ib) = asdir(iplon)
- albdif(ib) = asdif(iplon)
- enddo
-
-
-! Clouds
- if (icld.eq.0) then
-
- zcldfmc(:,:) = 0._rb
- ztaucmc(:,:) = 0._rb
- ztaormc(:,:) = 0._rb
- zasycmc(:,:) = 0._rb
- zomgcmc(:,:) = 1._rb
-
- elseif (icld.ge.1) then
- do i=1,nlayers
- do ig=1,ngptsw
- zcldfmc(i,ig) = cldfmc(ig,i)
- ztaucmc(i,ig) = taucmc(ig,i)
- ztaormc(i,ig) = taormc(ig,i)
- zasycmc(i,ig) = asmcmc(ig,i)
- zomgcmc(i,ig) = ssacmc(ig,i)
- enddo
- enddo
-
- endif
-
-! Aerosol
-! IAER = 0: no aerosols
- if (iaer.eq.0) then
-
- ztaua(:,:) = 0._rb
- zasya(:,:) = 0._rb
- zomga(:,:) = 1._rb
-
-! IAER = 6: Use ECMWF six aerosol types. See rrsw_aer.f90 for details.
-! Input aerosol optical thickness at 0.55 micron for each aerosol type (ecaer),
-! or set manually here for each aerosol and layer.
- elseif (iaer.eq.6) then
-
-! do i = 1, nlayers
-! do ia = 1, naerec
-! ecaer(iplon,i,ia) = 1.0e-15_rb
-! enddo
-! enddo
-
- do i = 1, nlayers
- do ib = 1, nbndsw
- ztaua(i,ib) = 0._rb
- zasya(i,ib) = 0._rb
- zomga(i,ib) = 0._rb
- do ia = 1, naerec
- ztaua(i,ib) = ztaua(i,ib) + rsrtaua(ib,ia) * ecaer(iplon,i,ia)
- zomga(i,ib) = zomga(i,ib) + rsrtaua(ib,ia) * ecaer(iplon,i,ia) * &
- rsrpiza(ib,ia)
- zasya(i,ib) = zasya(i,ib) + rsrtaua(ib,ia) * ecaer(iplon,i,ia) * &
- rsrpiza(ib,ia) * rsrasya(ib,ia)
- enddo
- if (zomga(i,ib) /= 0._rb) then
- zasya(i,ib) = zasya(i,ib) / zomga(i,ib)
- endif
- if (ztaua(i,ib) /= 0._rb) then
- zomga(i,ib) = zomga(i,ib) / ztaua(i,ib)
- endif
- enddo
- enddo
-
-! IAER=10: Direct specification of aerosol optical properties from GCM
- elseif (iaer.eq.10) then
-
- do i = 1 ,nlayers
- do ib = 1 ,nbndsw
- ztaua(i,ib) = taua(i,ib)
- ztauacln(i,ib) = 0.0
- zasya(i,ib) = asma(i,ib)
- zomga(i,ib) = ssaa(i,ib)
- enddo
- enddo
-
- endif
-
-
-! Call the 2-stream radiation transfer model
-
- do i=1,nlayers+1
- zbbcu(i) = 0._rb
- zbbcd(i) = 0._rb
- zbbfu(i) = 0._rb
- zbbfd(i) = 0._rb
- zbbcddir(i) = 0._rb
- zbbfddir(i) = 0._rb
- zuvcd(i) = 0._rb
- zuvfd(i) = 0._rb
- zuvcddir(i) = 0._rb
- zuvfddir(i) = 0._rb
- znicd(i) = 0._rb
- znifd(i) = 0._rb
- znicddir(i) = 0._rb
- znifddir(i) = 0._rb
- enddo
-
- call spcvmc_sw &
- (nlayers, istart, iend, icpr, iout, &
- pavel, tavel, pz, tz, tbound, albdif, albdir, &
- zcldfmc, ztaucmc, zasycmc, zomgcmc, ztaormc, &
- ztaua, zasya, zomga, cossza, coldry, wkl, adjflux, &
- laytrop, layswtch, laylow, jp, jt, jt1, &
- co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3, &
- fac00, fac01, fac10, fac11, &
- selffac, selffrac, indself, forfac, forfrac, indfor, &
- zbbfd, zbbfu, zbbcd, zbbcu, zuvfd, zuvcd, znifd, znicd, &
- zbbfddir, zbbcddir, zuvfddir, zuvcddir, znifddir, znicddir)
-
-! Transfer up and down, clear and total sky fluxes to output arrays.
-! Vertical indexing goes from bottom to top; reverse here for GCM if necessary.
-
- do i = 1, nlayers+1
- swuflxc(iplon,i) = zbbcu(i)
- swdflxc(iplon,i) = zbbcd(i)
- swuflx(iplon,i) = zbbfu(i)
- swdflx(iplon,i) = zbbfd(i)
- uvdflx(i) = zuvfd(i)
- nidflx(i) = znifd(i)
-
-! Direct/diffuse fluxes
- dirdflux(i) = zbbfddir(i)
- difdflux(i) = swdflx(iplon,i) - dirdflux(i)
- swdkdir(iplon,i) = dirdflux(i) ! all-sky direct flux jararias, 2013/08/10
- swdkdif(iplon,i) = difdflux(i) ! all-sky diffuse flux jararias, 2013/08/10
- swdkdirc(iplon,i) = zbbcddir(i) ! PAJ: clear-sky direct flux
-
-! UV/visible direct/diffuse fluxes
- dirdnuv(i) = zuvfddir(i)
- difdnuv(i) = zuvfd(i) - dirdnuv(i)
-! ------- Zhenxin add vis/uv downwards dir or dif here --!
- sibvisdir(iplon,i) = dirdnuv(i)
- sibvisdif(iplon,i) = difdnuv(i)
-! ----- End of Zhenxin addition ------------!
-! Near-IR direct/diffuse fluxes
- dirdnir(i) = znifddir(i)
- difdnir(i) = znifd(i) - dirdnir(i)
-! ---------Zhenxin add nir downwards dir and dif here --!
- sibnirdir(iplon,i) = dirdnir(i)
- sibnirdif(iplon,i) = difdnir(i)
-! -------- End of Zhenxin addition 2011-05 ---------!
- enddo
-
-! Total and clear sky net fluxes
- do i = 1, nlayers+1
- swnflxc(i) = swdflxc(iplon,i) - swuflxc(iplon,i)
- swnflx(i) = swdflx(iplon,i) - swuflx(iplon,i)
- enddo
-
-! Total and clear sky heating rates
- do i = 1, nlayers
- zdpgcp = heatfac / pdp(i)
- swhrc(iplon,i) = (swnflxc(i+1) - swnflxc(i)) * zdpgcp
- swhr(iplon,i) = (swnflx(i+1) - swnflx(i)) * zdpgcp
- enddo
- swhrc(iplon,nlayers) = 0._rb
- swhr(iplon,nlayers) = 0._rb
-
-#if (WRF_CHEM == 1)
- ! Repeat call to 2-stream radiation model using "clean sky"
- ! variables and aerosol tau set to 0
- if(calc_clean_atm_diag .gt. 0)then
- do i=1,nlayers+1
- zbbcu(i) = 0._rb
- zbbcd(i) = 0._rb
- zbbclnu(i) = 0._rb
- zbbclnd(i) = 0._rb
- zbbcddir(i) = 0._rb
- zbbclnddir(i) = 0._rb
- zuvcd(i) = 0._rb
- zuvclnd(i) = 0._rb
- zuvcddir(i) = 0._rb
- zuvclnddir(i) = 0._rb
- znicd(i) = 0._rb
- zniclnd(i) = 0._rb
- znicddir(i) = 0._rb
- zniclnddir(i) = 0._rb
- enddo
-
- call spcvmc_sw &
- (nlayers, istart, iend, icpr, iout, &
- pavel, tavel, pz, tz, tbound, albdif, albdir, &
- zcldfmc, ztaucmc, zasycmc, zomgcmc, ztaormc, &
- ztauacln, zasya, zomga, cossza, coldry, wkl, adjflux, &
- laytrop, layswtch, laylow, jp, jt, jt1, &
- co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3, &
- fac00, fac01, fac10, fac11, &
- selffac, selffrac, indself, forfac, forfrac, indfor, &
- zbbclnd, zbbclnu, zbbcd, zbbcu, zuvclnd, zuvcd, zniclnd, znicd, &
- zbbclnddir, zbbcddir, zuvclnddir, zuvcddir, zniclnddir, znicddir)
-
- do i = 1, nlayers+1
- swuflxcln(iplon,i) = zbbclnu(i)
- swdflxcln(iplon,i) = zbbclnd(i)
- enddo
- else
- do i = 1, nlayers+1
- swuflxcln(iplon,i) = 0.0
- swdflxcln(iplon,i) = 0.0
- enddo
- end if
-
-#else
- do i = 1, nlayers+1
- swuflxcln(iplon,i) = 0.0
- swdflxcln(iplon,i) = 0.0
- enddo
-
-#endif
-! End longitude loop
- enddo
-
-! begin WRF-CMAQ twoway coupled model block
- sw_zbbcddir = zbbcddir(1)
- sw_dirdflux = dirdflux(1)
- sw_difdflux = difdflux(1)
-! end WRF-CMAQ twoway coupled model block
-
- end subroutine rrtmg_sw
-
-!*************************************************************************
- real(kind=rb) function earth_sun(idn)
-!*************************************************************************
-!
-! Purpose: Function to calculate the correction factor of Earth's orbit
-! for current day of the year
-
-! idn : Day of the year
-! earth_sun : square of the ratio of mean to actual Earth-Sun distance
-
-! ------- Modules -------
-
- use rrsw_con, only : pi
-
- integer(kind=im), intent(in) :: idn
-
- real(kind=rb) :: gamma
-
- gamma = 2._rb*pi*(idn-1)/365._rb
-
-! Use Iqbal's equation 1.2.1
-
- earth_sun = 1.000110_rb + .034221_rb * cos(gamma) + .001289_rb * sin(gamma) + &
- .000719_rb * cos(2._rb*gamma) + .000077_rb * sin(2._rb*gamma)
-
- end function earth_sun
-
-!***************************************************************************
- subroutine inatm_sw (iplon, nlay, icld, iaer, &
- play, plev, tlay, tlev, tsfc, h2ovmr, &
- o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, &
- adjes, dyofyr, scon, inflgsw, iceflgsw, liqflgsw, &
- cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl, ciwpmcl, clwpmcl, cswpmcl, &
- reicmcl, relqmcl, resnmcl, tauaer, ssaaer, asmaer, &
- nlayers, pavel, pz, pdp, tavel, tz, tbound, coldry, wkl, &
- adjflux, solvar, inflag, iceflag, liqflag, cldfmc, taucmc, &
- ssacmc, asmcmc, fsfcmc, ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, &
- taua, ssaa, asma)
-!***************************************************************************
-!
-! Input atmospheric profile from GCM, and prepare it for use in RRTMG_SW.
-! Set other RRTMG_SW input parameters.
-!
-!***************************************************************************
-
-! --------- Modules ----------
-
- use parrrsw, only : nbndsw, ngptsw, nstr, nmol, mxmol, &
- jpband, jpb1, jpb2, rrsw_scon
- use rrsw_con, only : heatfac, oneminus, pi, grav, avogad
- use rrsw_wvn, only : ng, nspa, nspb, wavenum1, wavenum2, delwave
-
-! ------- Declarations -------
-
-! ----- Input -----
- integer(kind=im), intent(in) :: iplon ! column loop index
- integer(kind=im), intent(in) :: nlay ! number of model layers
- integer(kind=im), intent(in) :: icld ! clear/cloud and cloud overlap flag
- integer(kind=im), intent(in) :: iaer ! aerosol option flag
-
- real(kind=rb), intent(in) :: play(:,:) ! Layer pressures (hPa, mb)
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: plev(:,:) ! Interface pressures (hPa, mb)
- ! Dimensions: (ncol,nlay+1)
- real(kind=rb), intent(in) :: tlay(:,:) ! Layer temperatures (K)
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: tlev(:,:) ! Interface temperatures (K)
- ! Dimensions: (ncol,nlay+1)
- real(kind=rb), intent(in) :: tsfc(:) ! Surface temperature (K)
- ! Dimensions: (ncol)
- real(kind=rb), intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: o2vmr(:,:) ! Oxygen volume mixing ratio
- ! Dimensions: (ncol,nlay)
-
- integer(kind=im), intent(in) :: dyofyr ! Day of the year (used to get Earth/Sun
- ! distance if adjflx not provided)
- real(kind=rb), intent(in) :: adjes ! Flux adjustment for Earth/Sun distance
- real(kind=rb), intent(in) :: scon ! Solar constant (W/m2)
-
- integer(kind=im), intent(in) :: inflgsw ! Flag for cloud optical properties
- integer(kind=im), intent(in) :: iceflgsw ! Flag for ice particle specification
- integer(kind=im), intent(in) :: liqflgsw ! Flag for liquid droplet specification
-
- real(kind=rb), intent(in) :: cldfmcl(:,:,:) ! Cloud fraction
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(in) :: taucmcl(:,:,:) ! In-cloud optical depth (optional)
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(in) :: ssacmcl(:,:,:) ! In-cloud single scattering albedo
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(in) :: asmcmcl(:,:,:) ! In-cloud asymmetry parameter
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(in) :: fsfcmcl(:,:,:) ! In-cloud forward scattering fraction
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(in) :: ciwpmcl(:,:,:) ! In-cloud ice water path (g/m2)
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(in) :: clwpmcl(:,:,:) ! In-cloud liquid water path (g/m2)
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(in) :: cswpmcl(:,:,:) ! In-cloud snow water path (g/m2)
- ! Dimensions: (ngptsw,ncol,nlay)
- real(kind=rb), intent(in) :: reicmcl(:,:) ! Cloud ice effective size (microns)
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns)
- ! Dimensions: (ncol,nlay)
- real(kind=rb), intent(in) :: resnmcl(:,:) ! Cloud snow effective radius (microns)
- ! Dimensions: (ncol,nlay)
-
- real(kind=rb), intent(in) :: tauaer(:,:,:) ! Aerosol optical depth
- ! Dimensions: (ncol,nlay,nbndsw)
- real(kind=rb), intent(in) :: ssaaer(:,:,:) ! Aerosol single scattering albedo
- ! Dimensions: (ncol,nlay,nbndsw)
- real(kind=rb), intent(in) :: asmaer(:,:,:) ! Aerosol asymmetry parameter
- ! Dimensions: (ncol,nlay,nbndsw)
-
-! Atmosphere
- integer(kind=im), intent(out) :: nlayers ! number of layers
-
- real(kind=rb), intent(out) :: pavel(:) ! layer pressures (mb)
- ! Dimensions: (nlay)
- real(kind=rb), intent(out) :: tavel(:) ! layer temperatures (K)
- ! Dimensions: (nlay)
- real(kind=rb), intent(out) :: pz(0:) ! level (interface) pressures (hPa, mb)
- ! Dimensions: (0:nlay)
- real(kind=rb), intent(out) :: tz(0:) ! level (interface) temperatures (K)
- ! Dimensions: (0:nlay)
- real(kind=rb), intent(out) :: tbound ! surface temperature (K)
- real(kind=rb), intent(out) :: pdp(:) ! layer pressure thickness (hPa, mb)
- ! Dimensions: (nlay)
- real(kind=rb), intent(out) :: coldry(:) ! dry air column density (mol/cm2)
- ! Dimensions: (nlay)
- real(kind=rb), intent(out) :: wkl(:,:) ! molecular amounts (mol/cm-2)
- ! Dimensions: (mxmol,nlay)
-
- real(kind=rb), intent(out) :: adjflux(:) ! adjustment for current Earth/Sun distance
- ! Dimensions: (jpband)
- real(kind=rb), intent(out) :: solvar(:) ! solar constant scaling factor from rrtmg_sw
- ! Dimensions: (jpband)
- ! default value of 1368.22 Wm-2 at 1 AU
- real(kind=rb), intent(out) :: taua(:,:) ! Aerosol optical depth
- ! Dimensions: (nlay,nbndsw)
- real(kind=rb), intent(out) :: ssaa(:,:) ! Aerosol single scattering albedo
- ! Dimensions: (nlay,nbndsw)
- real(kind=rb), intent(out) :: asma(:,:) ! Aerosol asymmetry parameter
- ! Dimensions: (nlay,nbndsw)
-
-! Atmosphere/clouds - cldprop
- integer(kind=im), intent(out) :: inflag ! flag for cloud property method
- integer(kind=im), intent(out) :: iceflag ! flag for ice cloud properties
- integer(kind=im), intent(out) :: liqflag ! flag for liquid cloud properties
-
- real(kind=rb), intent(out) :: cldfmc(:,:) ! layer cloud fraction
- ! Dimensions: (ngptsw,nlay)
- real(kind=rb), intent(out) :: taucmc(:,:) ! in-cloud optical depth (non-delta scaled)
- ! Dimensions: (ngptsw,nlay)
- real(kind=rb), intent(out) :: ssacmc(:,:) ! in-cloud single scattering albedo (non-delta-scaled)
- ! Dimensions: (ngptsw,nlay)
- real(kind=rb), intent(out) :: asmcmc(:,:) ! in-cloud asymmetry parameter (non-delta scaled)
- ! Dimensions: (ngptsw,nlay)
- real(kind=rb), intent(out) :: fsfcmc(:,:) ! in-cloud forward scattering fraction (non-delta scaled)
- ! Dimensions: (ngptsw,nlay)
- real(kind=rb), intent(out) :: ciwpmc(:,:) ! in-cloud ice water path
- ! Dimensions: (ngptsw,nlay)
- real(kind=rb), intent(out) :: clwpmc(:,:) ! in-cloud liquid water path
- ! Dimensions: (ngptsw,nlay)
- real(kind=rb), intent(out) :: cswpmc(:,:) ! in-cloud snow path
- ! Dimensions: (ngptsw,nlay)
- real(kind=rb), intent(out) :: relqmc(:) ! liquid particle effective radius (microns)
- ! Dimensions: (nlay)
- real(kind=rb), intent(out) :: reicmc(:) ! ice particle effective size (microns)
- ! Dimensions: (nlay)
- real(kind=rb), intent(out) :: resnmc(:) ! snow particle effective size (microns)
- ! Dimensions: (nlay)
-
-! ----- Local -----
- real(kind=rb), parameter :: amd = 28.9660_rb ! Effective molecular weight of dry air (g/mol)
- real(kind=rb), parameter :: amw = 18.0160_rb ! Molecular weight of water vapor (g/mol)
-! real(kind=rb), parameter :: amc = 44.0098_rb ! Molecular weight of carbon dioxide (g/mol)
-! real(kind=rb), parameter :: amo = 47.9998_rb ! Molecular weight of ozone (g/mol)
-! real(kind=rb), parameter :: amo2 = 31.9999_rb ! Molecular weight of oxygen (g/mol)
-! real(kind=rb), parameter :: amch4 = 16.0430_rb ! Molecular weight of methane (g/mol)
-! real(kind=rb), parameter :: amn2o = 44.0128_rb ! Molecular weight of nitrous oxide (g/mol)
-
-! Set molecular weight ratios (for converting mmr to vmr)
-! e.g. h2ovmr = h2ommr * amdw)
- real(kind=rb), parameter :: amdw = 1.607793_rb ! Molecular weight of dry air / water vapor
- real(kind=rb), parameter :: amdc = 0.658114_rb ! Molecular weight of dry air / carbon dioxide
- real(kind=rb), parameter :: amdo = 0.603428_rb ! Molecular weight of dry air / ozone
- real(kind=rb), parameter :: amdm = 1.805423_rb ! Molecular weight of dry air / methane
- real(kind=rb), parameter :: amdn = 0.658090_rb ! Molecular weight of dry air / nitrous oxide
- real(kind=rb), parameter :: amdo2 = 0.905140_rb ! Molecular weight of dry air / oxygen
-
- real(kind=rb), parameter :: sbc = 5.67e-08_rb ! Stefan-Boltzmann constant (W/m2K4)
-
- integer(kind=im) :: isp, l, ix, n, imol, ib, ig ! Loop indices
- real(kind=rb) :: amm, summol !
- real(kind=rb) :: adjflx ! flux adjustment for Earth/Sun distance
-! real(kind=rb) :: earth_sun ! function for Earth/Sun distance adjustment
-
- nlayers = nlay
-
-! Initialize all molecular amounts to zero here, then pass input amounts
-! into RRTM array WKL below.
-
- wkl(:,:) = 0.0_rb
- cldfmc(:,:) = 0.0_rb
- taucmc(:,:) = 0.0_rb
- ssacmc(:,:) = 1.0_rb
- asmcmc(:,:) = 0.0_rb
- fsfcmc(:,:) = 0.0_rb
- ciwpmc(:,:) = 0.0_rb
- clwpmc(:,:) = 0.0_rb
- cswpmc(:,:) = 0.0_rb
- reicmc(:) = 0.0_rb
- relqmc(:) = 0.0_rb
- resnmc(:) = 0.0_rb
- taua(:,:) = 0.0_rb
- ssaa(:,:) = 1.0_rb
- asma(:,:) = 0.0_rb
-
-! Set flux adjustment for current Earth/Sun distance (two options).
-! 1) Use Earth/Sun distance flux adjustment provided by GCM (input as adjes);
- adjflx = adjes
-!
-! 2) Calculate Earth/Sun distance from DYOFYR, the cumulative day of the year.
-! (Set adjflx to 1. to use constant Earth/Sun distance of 1 AU).
- if (dyofyr .gt. 0) then
- adjflx = earth_sun(dyofyr)
- endif
-
-! Set incoming solar flux adjustment to include adjustment for
-! current Earth/Sun distance (ADJFLX) and scaling of default internal
-! solar constant (rrsw_scon = 1368.22 Wm-2) by band (SOLVAR). SOLVAR can be set
-! to a single scaling factor as needed, or to a different value in each
-! band, which may be necessary for paleoclimate simulations.
-!
- do ib = jpb1,jpb2
-! solvar(ib) = 1._rb
- solvar(ib) = scon / rrsw_scon
- adjflux(ib) = adjflx * solvar(ib)
- enddo
-
-! Set surface temperature.
- tbound = tsfc(iplon)
-
-! Install input GCM arrays into RRTMG_SW arrays for pressure, temperature,
-! and molecular amounts.
-! Pressures are input in mb, or are converted to mb here.
-! Molecular amounts are input in volume mixing ratio, or are converted from
-! mass mixing ratio (or specific humidity for h2o) to volume mixing ratio
-! here. These are then converted to molecular amount (molec/cm2) below.
-! The dry air column COLDRY (in molec/cm2) is calculated from the level
-! pressures, pz (in mb), based on the hydrostatic equation and includes a
-! correction to account for h2o in the layer. The molecular weight of moist
-! air (amm) is calculated for each layer.
-! Note: In RRTMG, layer indexing goes from bottom to top, and coding below
-! assumes GCM input fields are also bottom to top. Input layer indexing
-! from GCM fields should be reversed here if necessary.
-
- pz(0) = plev(iplon,1)
- tz(0) = tlev(iplon,1)
- do l = 1, nlayers
- pavel(l) = play(iplon,l)
- tavel(l) = tlay(iplon,l)
- pz(l) = plev(iplon,l+1)
- tz(l) = tlev(iplon,l+1)
- pdp(l) = pz(l-1) - pz(l)
-! For h2o input in vmr:
- wkl(1,l) = h2ovmr(iplon,l)
-! For h2o input in mmr:
-! wkl(1,l) = h2o(iplon,l)*amdw
-! For h2o input in specific humidity;
-! wkl(1,l) = (h2o(iplon,l)/(1._rb - h2o(iplon,l)))*amdw
- wkl(2,l) = co2vmr(iplon,l)
- wkl(3,l) = o3vmr(iplon,l)
- wkl(4,l) = n2ovmr(iplon,l)
- wkl(6,l) = ch4vmr(iplon,l)
- wkl(7,l) = o2vmr(iplon,l)
- amm = (1._rb - wkl(1,l)) * amd + wkl(1,l) * amw
- coldry(l) = (pz(l-1)-pz(l)) * 1.e3_rb * avogad / &
- (1.e2_rb * grav * amm * (1._rb + wkl(1,l)))
- enddo
-
-! The following section can be used to set values for an additional layer (from
-! the GCM top level to 1.e-4 mb) for improved calculation of TOA fluxes.
-! Temperature and molecular amounts in the extra model layer are set to
-! their values in the top GCM model layer, though these can be modified
-! here if necessary.
-! If this feature is utilized, increase nlayers by one above, limit the two
-! loops above to (nlayers-1), and set the top most (nlayers) layer values here.
-
-! pavel(nlayers) = 0.5_rb * pz(nlayers-1)
-! tavel(nlayers) = tavel(nlayers-1)
-! pz(nlayers) = 1.e-4_rb
-! tz(nlayers-1) = 0.5_rb * (tavel(nlayers)+tavel(nlayers-1))
-! tz(nlayers) = tz(nlayers-1)
-! pdp(nlayers) = pz(nlayers-1) - pz(nlayers)
-! wkl(1,nlayers) = wkl(1,nlayers-1)
-! wkl(2,nlayers) = wkl(2,nlayers-1)
-! wkl(3,nlayers) = wkl(3,nlayers-1)
-! wkl(4,nlayers) = wkl(4,nlayers-1)
-! wkl(6,nlayers) = wkl(6,nlayers-1)
-! wkl(7,nlayers) = wkl(7,nlayers-1)
-! amm = (1._rb - wkl(1,nlayers-1)) * amd + wkl(1,nlayers-1) * amw
-! coldry(nlayers) = (pz(nlayers-1)) * 1.e3_rb * avogad / &
-! (1.e2_rb * grav * amm * (1._rb + wkl(1,nlayers-1)))
-
-! At this point all molecular amounts in wkl are in volume mixing ratio;
-! convert to molec/cm2 based on coldry for use in rrtm.
-
- do l = 1, nlayers
- do imol = 1, nmol
- wkl(imol,l) = coldry(l) * wkl(imol,l)
- enddo
- enddo
-
-! Transfer aerosol optical properties to RRTM variables;
-! modify to reverse layer indexing here if necessary.
-
- if (iaer .ge. 1) then
- do l = 1, nlayers
- do ib = 1, nbndsw
- taua(l,ib) = tauaer(iplon,l,ib)
- ssaa(l,ib) = ssaaer(iplon,l,ib)
- asma(l,ib) = asmaer(iplon,l,ib)
- enddo
- enddo
- endif
-
-! Transfer cloud fraction and cloud optical properties to RRTM variables;
-! modify to reverse layer indexing here if necessary.
-
- if (icld .ge. 1) then
- inflag = inflgsw
- iceflag = iceflgsw
- liqflag = liqflgsw
-
-! Move incoming GCM cloud arrays to RRTMG cloud arrays.
-! For GCM input, incoming reicmcl is defined based on selected ice parameterization (inflgsw)
-
- do l = 1, nlayers
- do ig = 1, ngptsw
- cldfmc(ig,l) = cldfmcl(ig,iplon,l)
- taucmc(ig,l) = taucmcl(ig,iplon,l)
- ssacmc(ig,l) = ssacmcl(ig,iplon,l)
- asmcmc(ig,l) = asmcmcl(ig,iplon,l)
- fsfcmc(ig,l) = fsfcmcl(ig,iplon,l)
- ciwpmc(ig,l) = ciwpmcl(ig,iplon,l)
- clwpmc(ig,l) = clwpmcl(ig,iplon,l)
- if (iceflag.eq.5) then
- cswpmc(ig,l)=cswpmcl(ig,iplon,l)
- endif
- enddo
- reicmc(l) = reicmcl(iplon,l)
- relqmc(l) = relqmcl(iplon,l)
- if (iceflag.eq.5) then
- resnmc(l) = resnmcl(iplon,l)
- endif
- enddo
-
-! If an extra layer is being used in RRTMG, set all cloud properties to zero in the extra layer.
-
-! cldfmc(:,nlayers) = 0.0_rb
-! taucmc(:,nlayers) = 0.0_rb
-! ssacmc(:,nlayers) = 1.0_rb
-! asmcmc(:,nlayers) = 0.0_rb
-! fsfcmc(:,nlayers) = 0.0_rb
-! ciwpmc(:,nlayers) = 0.0_rb
-! clwpmc(:,nlayers) = 0.0_rb
-! reicmc(nlayers) = 0.0_rb
-! relqmc(nlayers) = 0.0_rb
-
- endif
-
- end subroutine inatm_sw
-
- end module rrtmg_sw_rad
-
-!------------------------------------------------------------------
-MODULE module_ra_rrtmg_sw
-
-use module_model_constants, only : cp
-USE module_wrf_error
-#if (HWRF == 1)
-USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT, ETAMP_HWRF
-#else
-USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT
-#endif
-!USE module_dm
-
-use parrrsw, only : nbndsw, ngptsw, naerec
-use rrtmg_sw_init, only: rrtmg_sw_ini
-use rrtmg_sw_rad, only: rrtmg_sw
-use mcica_subcol_gen_sw, only: mcica_subcol_sw
-
-use module_ra_rrtmg_lw, only : inirad, o3data, relcalc, reicalc, retab
-! mcica_random_numbers, randomNumberSequence, &
-! new_RandomNumberSequence, getRandomReal
-use module_twoway_ra_rrtmg_sw
-
-CONTAINS
-
-!------------------------------------------------------------------
- SUBROUTINE RRTMG_SWRAD( &
- rthratensw, &
- rthratenswc, &
- swupt, swuptc, swuptcln, swdnt, swdntc, swdntcln, &
- swupb, swupbc, swupbcln, swdnb, swdnbc, swdnbcln, &
-! swupflx, swupflxc, swdnflx, swdnflxc, &
- swcf, gsw, &
- xtime, gmt, xlat, xlong, &
- radt, degrad, declin, &
- coszr, julday, solcon, &
- albedo, t3d, t8w, tsk, &
- p3d, p8w, pi3d, rho3d, &
- dz8w, cldfra3d, lradius, iradius, &
- is_cammgmp_used, r, g, &
- re_cloud,re_ice,re_snow, &
- has_reqc,has_reqi,has_reqs, &
- icloud, warm_rain, &
- cldovrlp, & ! J. Henderson AER: cldovrlp namelist value
- f_ice_phy, f_rain_phy, &
- xland, xice, snow, &
- qv3d, qc3d, qr3d, &
- qi3d, qs3d, qg3d, &
- o3input, o33d, &
- aer_opt, aerod, no_src, &
- alswvisdir, alswvisdif, & !Zhenxin ssib alb comp (06/20/2011)
- alswnirdir, alswnirdif, & !Zhenxin ssib alb comp (06/20/2011)
- swvisdir, swvisdif, & !Zhenxin ssib swr comp (06/20/2011)
- swnirdir, swnirdif, & !Zhenxin ssib swi comp (06/20/2011)
- sf_surface_physics, & !Zhenxin
- f_qv, f_qc, f_qr, f_qi, f_qs, f_qg, &
- tauaer300,tauaer400,tauaer600,tauaer999, & ! czhao
- gaer300,gaer400,gaer600,gaer999, & ! czhao
- waer300,waer400,waer600,waer999, & ! czhao
- aer_ra_feedback, &
-!jdfcz progn,prescribe, &
- progn,calc_clean_atm_diag, &
- qndrop3d,f_qndrop, & !czhao
- mp_physics, & !wang 2014/12
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte, &
- swupflx, swupflxc, &
- swdnflx, swdnflxc, &
- tauaer3d_sw,ssaaer3d_sw,asyaer3d_sw, & ! jararias 2013/11
- swddir, swddni, swddif, & ! jararias 2013/08
- swdownc, swddnic, swddirc, & ! PAJ
- xcoszen,yr,julian, & ! jararias 2013/08
- obscur & ! amontornes-bcodina 2015/09 solar eclipses
- ,proceed_twoway_sw, & ! WRF-CMAQ twoway coupled model
- nmode, & ! WRF-CMAQ twoway coupled model
- mass_ws_i, mass_ws_j, mass_ws_k, & ! WRF-CMAQ twoway coupled model
- mass_in_i, mass_in_j, mass_in_k, & ! WRF-CMAQ twoway coupled model
- mass_ec_i, mass_ec_j, mass_ec_k, & ! WRF-CMAQ twoway coupled model
- mass_ss_i, mass_ss_j, mass_ss_k, & ! WRF-CMAQ twoway coupled model
- mass_h2o_i, mass_h2o_j, mass_h2o_k, & ! WRF-CMAQ twoway coupled model
- dgn_i, dgn_j, dgn_k, & ! WRF-CMAQ twoway coupled model
- sig_i, sig_j, sig_k, & ! WRF-CMAQ twoway coupled model
- gtauxar_01, gtauxar_02, gtauxar_03, & ! WRF-CMAQ twoway coupled model
- gtauxar_04, gtauxar_05, & ! WRF-CMAQ twoway coupled model
- asy_fac_01, asy_fac_02, asy_fac_03, & ! WRF-CMAQ twoway coupled model
- asy_fac_04, asy_fac_05, & ! WRF-CMAQ twoway coupled model
- ssa_01, ssa_02, ssa_03, & ! WRF-CMAQ twoway coupled model
- ssa_04, ssa_05 & ! WRF-CMAQ twoway coupled model
- ,sw_zbbcddir & ! WRF-CMAQ twoway coupled model
- ,sw_dirdflux & ! WRF-CMAQ twoway coupled model
- ,sw_difdflux & ! WRF-CMAQ twoway coupled model
- )
-!------------------------------------------------------------------
- IMPLICIT NONE
-!------------------------------------------------------------------
- LOGICAL, INTENT(IN ) :: warm_rain
- LOGICAL, INTENT(IN ) :: is_CAMMGMP_used ! Added for CAM5 RRTMG<->CAMMGMP
-!
- INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte
-
- INTEGER, INTENT(IN ) :: ICLOUD
- INTEGER, INTENT(IN ) :: MP_PHYSICS
-!
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
- INTENT(IN ) :: dz8w, &
- t3d, &
- t8w, &
- p3d, &
- p8w, &
- pi3d, &
- rho3d
-
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
- INTENT(INOUT) :: RTHRATENSW, &
- RTHRATENSWC
-
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(INOUT) :: GSW, &
- SWCF, &
- COSZR
-
- INTEGER, INTENT(IN ) :: JULDAY
- REAL, INTENT(IN ) :: RADT,DEGRAD, &
- XTIME,DECLIN,SOLCON,GMT
-
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(IN ) :: XLAT, &
- XLONG, &
- XLAND, &
- XICE, &
- SNOW, &
- TSK, &
- ALBEDO
-!
-!!! ------------------- Zhenxin (2011-06/20) ------------------
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- OPTIONAL , &
- INTENT(IN) :: ALSWVISDIR, & ! ssib albedo of sw and lw
- ALSWVISDIF, &
- ALSWNIRDIR, &
- ALSWNIRDIF
-
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- OPTIONAL , &
- INTENT(OUT) :: SWVISDIR, &
- SWVISDIF, &
- SWNIRDIR, &
- SWNIRDIF ! ssib sw dir and diff rad
- INTEGER, INTENT(IN) :: sf_surface_physics ! ssib para
-
-! ----------------------- end Zhenxin --------------------------
-!
-
-! ------------------------ jararias 2013/08/10 -----------------
- real, dimension(ims:ime,jms:jme), intent(out) :: &
- swddir, & ! All-sky broadband surface direct horiz irradiance
- swddni, & ! All-sky broadband surface direct normal irradiance
- swddif, & ! All-sky broadband surface diffuse irradiance
- swdownc, & ! Clear sky GHI
- swddnic, & ! Clear ski DNI
- swddirc ! Clear ski direct horizontal irradiance
-
- integer, intent(in) :: yr
- real, optional, intent(in) :: &
- julian ! julian day (1-366)
- real, dimension(ims:ime,jms:jme), intent(in) :: &
- xcoszen ! cosine of the solar zenith angle
- real, dimension(:,:,:,:), pointer :: tauaer3d_sw,ssaaer3d_sw,asyaer3d_sw
-! ------------------------ jararias end snippet -----------------
-
- REAL, INTENT(IN ) :: R,G
-!
-! Optional
-!
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
- OPTIONAL , &
- INTENT(IN ) :: &
- CLDFRA3D, &
- LRADIUS, &
- IRADIUS, &
- QV3D, &
- QC3D, &
- QR3D, &
- QI3D, &
- QS3D, &
- QG3D, &
- QNDROP3D
-
-!..Added by G. Thompson to couple cloud physics effective radii.
- REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN):: &
- RE_CLOUD, &
- RE_ICE, &
- RE_SNOW
- INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs
-
- real pi,third,relconst,lwpmin,rhoh2o
-
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
- OPTIONAL , &
- INTENT(IN ) :: &
- F_ICE_PHY, &
- F_RAIN_PHY
-
- LOGICAL, OPTIONAL, INTENT(IN) :: &
- F_QV,F_QC,F_QR,F_QI,F_QS,F_QG,F_QNDROP
-
-! Optional
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , &
- INTENT(IN ) :: tauaer300,tauaer400,tauaer600,tauaer999, & ! czhao
- gaer300,gaer400,gaer600,gaer999, & ! czhao
- waer300,waer400,waer600,waer999 ! czhao
-
- INTEGER, INTENT(IN ), OPTIONAL :: aer_ra_feedback
-!jdfcz INTEGER, INTENT(IN ), OPTIONAL :: progn,prescribe
- INTEGER, INTENT(IN ), OPTIONAL :: progn
- INTEGER, INTENT(IN ) :: calc_clean_atm_diag
-
-! Ozone
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
- OPTIONAL , &
- INTENT(IN ) :: O33D
- INTEGER, OPTIONAL, INTENT(IN ) :: o3input
-! EC aerosol: no_src = naerec = 6
- INTEGER, INTENT(IN ) :: no_src
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 1:no_src ) , &
- OPTIONAL , &
- INTENT(IN ) :: aerod
- INTEGER, OPTIONAL, INTENT(IN ) :: aer_opt
-
- !wavelength corresponding to wavenum1 and wavenum2 (cm-1)
- real, save :: wavemin(nbndsw) ! Min wavelength (um) of 14 intervals
- data wavemin /3.077,2.500,2.150,1.942,1.626,1.299, &
- 1.242,0.778,0.625,0.442,0.345,0.263,0.200,3.846/
- real, save :: wavemax(nbndsw) ! Max wavelength (um) of interval
- data wavemax/3.846,3.077,2.500,2.150,1.942,1.626, &
- 1.299,1.242,0.778,0.625,0.442,0.345,0.263,12.195/
- real wavemid(nbndsw) ! Mid wavelength (um) of interval
- real, parameter :: thresh=1.e-9
- real ang,slope
- character(len=200) :: msg
-
-! Top of atmosphere and surface shortwave fluxes (W m-2)
- REAL, DIMENSION( ims:ime, jms:jme ), &
- OPTIONAL, INTENT(INOUT) :: &
- SWUPT,SWUPTC,SWUPTCLN,SWDNT,SWDNTC,SWDNTCLN, &
- SWUPB,SWUPBC,SWUPBCLN,SWDNB,SWDNBC,SWDNBCLN
-
-! Layer shortwave fluxes (including extra layer above model top)
-! Vertical ordering is from bottom to top (W m-2)
- REAL, DIMENSION( ims:ime, kms:kme+2, jms:jme ), &
- OPTIONAL, INTENT(OUT) :: &
- SWUPFLX,SWUPFLXC, &
- SWDNFLX,SWDNFLXC
-
-! amontornes-bcodina 2015/09 solar eclipses
-! obscur --> degree of obscuration for solar eclipses prediction (2D)
- REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: obscur
-
-! begin WRF-CMAQ twoway coupled model block
- LOGICAL, INTENT(IN) :: proceed_twoway_sw
-
-! ** FSB items needed for new aerosol code from CMAQ
- integer, optional, intent(in) :: nmode ! number of log-normal modes
-
- real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: &
- mass_ws_i, mass_ws_j, mass_ws_k, & ! mass cocentrations in [ ug/m**3 ] for water
- ! soluble species in each mode
- mass_in_i, mass_in_j, mass_in_k, & ! mass cocentrations in [ ug/m**3 ] for water
- ! insoluble species in each mode
- mass_ec_i, mass_ec_j, mass_ec_k, & ! mass cocentrations in [ ug/m**3 ] for elemental
- ! carbon species in each mode
- mass_ss_i, mass_ss_j, mass_ss_k, & ! mass cocentrations in [ ug/m**3 ] for aerosol
- ! water species in each mode
- mass_h2o_i, mass_h2o_j, mass_h2o_k, & ! mass cocentrations in [ ug/m**3 ] for sea
- ! salt species in each mode
- dgn_i, dgn_j, dgn_k, & ! geometric mean diameter of each mode [ m ]
- sig_i, sig_j, sig_k ! geometric standard deviation of each mode
-
- real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(out) :: &
- gtauxar_01, & ! Aerosol optical depth of RRTMG SW band 11
- gtauxar_02, & ! Aerosol optical depth of RRTMG SW band 10
- gtauxar_03, & ! Aerosol optical depth of RRTMG SW band 9
- gtauxar_04, & ! Aerosol optical depth of RRTMG SW band 8
- gtauxar_05, & ! Aerosol optical depth of RRTMG SW band 7
- asy_fac_01, & ! asymmetry factor of RRTMG SW band 11
- asy_fac_02, & ! asymmetry factor of RRTMG SW band 10
- asy_fac_03, & ! asymmetry factor of RRTMG SW band 9
- asy_fac_04, & ! asymmetry factor of RRTMG SW band 8
- asy_fac_05, & ! asymmetry factor of RRTMG SW band 7
- ssa_01, & ! single scattering albedo of RRTMG SW band 11
- ssa_02, & ! single scattering albedo of RRTMG SW band 10
- ssa_03, & ! single scattering albedo of RRTMG SW band 9
- ssa_04, & ! single scattering albedo of RRTMG SW band 8
- ssa_05 ! single scattering albedo of RRTMG SW band 7
-
- REAL, DIMENSION( ims:ime, jms:jme ), optional, INTENT(OUT) :: &
- sw_zbbcddir, & ! clearsky downward direct shortwave flux (w/m2)
- sw_dirdflux, & ! Direct downward shortwave surface flux
- sw_difdflux ! Diffuse downward shortwave surface flux
-! end WRF-CMAQ twoway coupled model block
-
-! LOCAL VARS
-
- REAL, DIMENSION( kts:kte+1 ) :: Pw1D, &
- Tw1D
-
- REAL, DIMENSION( kts:kte ) :: TTEN1D, &
- CLDFRA1D, &
- DZ1D, &
- P1D, &
- T1D, &
- QV1D, &
- QC1D, &
- QR1D, &
- QI1D, &
- RHO1D, &
- QS1D, &
- QG1D, &
- O31D, &
- qndrop1d
-
-!BSF: From eq. (5) on p. 2434 in McFarquhar & Heymsfield (1996)
- real, parameter :: re_50C=1250.0/9.917, re_40C=1250.0/9.337, &
- re_30C=1250.0/9.208, re_20C=1250.0/9.387
-
-! Added local arrays for RRTMG
- integer :: ncol, &
- nlay, &
- icld, &
- cldovrlp, & ! J. Henderson AER
- inflgsw, &
- iceflgsw, &
- liqflgsw
-! Dimension with extra layer from model top to TOA
- real, dimension( 1, kts:kte+2 ) :: plev, &
- tlev
- real, dimension( 1, kts:kte+1 ) :: play, &
- tlay, &
- h2ovmr, &
- o3vmr, &
- co2vmr, &
- o2vmr, &
- ch4vmr, &
- n2ovmr
- real, dimension( kts:kte+1 ) :: o3mmr
-! mji - Add height of each layer for exponential-random cloud overlap
-! This will be derived below from the dz in each layer
- real, dimension( 1, kts:kte+1 ) :: hgt
- real :: dzsum
-! Surface albedo (for UV/visible and near-IR spectral regions,
-! and for direct and diffuse radiation)
- real, dimension( 1 ) :: asdir, &
- asdif, &
- aldir, &
- aldif
-! Dimension with extra layer from model top to TOA,
-! though no clouds are allowed in extra layer
- real, dimension( 1, kts:kte+1 ) :: clwpth, &
- ciwpth, &
- cswpth, &
- rel, &
- rei, &
- res, &
- cldfrac, &
- relqmcl, &
- reicmcl, &
- resnmcl
- real, dimension( nbndsw, 1, kts:kte+1 ) :: taucld, &
- ssacld, &
- asmcld, &
- fsfcld
- real, dimension( ngptsw, 1, kts:kte+1 ) :: cldfmcl, &
- clwpmcl, &
- ciwpmcl, &
- cswpmcl, &
- taucmcl, &
- ssacmcl, &
- asmcmcl, &
- fsfcmcl
- real, dimension( 1, kts:kte+1, nbndsw ) :: tauaer, &
- ssaaer, &
- asmaer
- real, dimension( 1, kts:kte+1, naerec ) :: ecaer
-
-! Output arrays contain extra layer from model top to TOA
- real, dimension( 1, kts:kte+2 ) :: swuflx, &
- swdflx, &
- swuflxc, &
- swdflxc, &
- swuflxcln, &
- swdflxcln, &
- sibvisdir, & ! Zhenxin 2011-06-20
- sibvisdif, &
- sibnirdir, &
- sibnirdif ! Zhenxin 2011-06-20
-
- real, dimension( 1, kts:kte+2 ) :: swdkdir, & ! jararias, 2013/08/10
- swdkdif, & ! jararias, 2013/08/10
- swdkdirc ! PAJ
-
- real, dimension( 1, kts:kte+1 ) :: swhr, &
- swhrc
-
- real, dimension ( 1 ) :: tsfc, &
- ps, &
- coszen
- real :: ro, &
- dz, &
- adjes, &
- scon, &
- snow_mass_factor
- integer :: dyofyr
-
- integer:: idx_rei
- real:: corr
-
-! Set trace gas volume mixing ratios, 2005 values, IPCC (2007)
-! carbon dioxide (379 ppmv) - this is being replaced by an annual function in v4.2
- real :: co2
-! data co2 / 379.e-6 /
-! methane (1774 ppbv)
- real :: ch4
- data ch4 / 1774.e-9 /
-! nitrous oxide (319 ppbv)
- real :: n2o
- data n2o / 319.e-9 /
-! Set oxygen volume mixing ratio (for o2mmr=0.23143)
- real :: o2
- data o2 / 0.209488 /
-
- integer :: iplon, irng, permuteseed
- integer :: nb
-
-! For old lw cloud property specification
-! Cloud and precipitation absorption coefficients
-! real :: abcw,abice,abrn,absn
-! data abcw /0.144/
-! data abice /0.0735/
-! data abrn /0.330e-3/
-! data absn /2.34e-3/
-
-! Molecular weights and ratios for converting mmr to vmr units
-! real :: amd ! Effective molecular weight of dry air (g/mol)
-! real :: amw ! Molecular weight of water vapor (g/mol)
-! real :: amo ! Molecular weight of ozone (g/mol)
-! real :: amo2 ! Molecular weight of oxygen (g/mol)
-! Atomic weights for conversion from mass to volume mixing ratios
-! data amd / 28.9660 /
-! data amw / 18.0160 /
-! data amo / 47.9998 /
-! data amo2 / 31.9999 /
-
- real :: amdw ! Molecular weight of dry air / water vapor
- real :: amdo ! Molecular weight of dry air / ozone
- real :: amdo2 ! Molecular weight of dry air / oxygen
- data amdw / 1.607793 /
- data amdo / 0.603461 /
- data amdo2 / 0.905190 /
-
-!!
- real, dimension(1, 1:kte-kts+1 ) :: pdel ! Layer pressure thickness (mb)
-
- real, dimension(1, 1:kte-kts+1) :: cicewp, & ! in-cloud cloud ice water path
- cliqwp, & ! in-cloud cloud liquid water path
- csnowp, & ! in-cloud snow water path
- reliq, & ! effective drop radius (microns)
- reice ! ice effective drop size (microns)
- real, dimension(1, 1:kte-kts+1):: recloud1d, &
- reice1d, &
- resnow1d
- real :: gliqwp, gicewp, gsnowp, gravmks, tem1,tem2,tem3
-
-!
-! REAL :: TSFC,GLW0,OLR0,EMISS0,FP
- REAL :: FP
-
-! real, dimension(1:ite-its+1 ) :: clat ! latitude in radians for columns
- real :: coszrs ! Cosine of solar zenith angle for present latitude
- logical :: dorrsw ! Flag to allow shortwave calculation
-
- real, dimension (1) :: landfrac, landm, snowh, icefrac
-
- integer :: pcols, pver
-
- INTEGER :: i,j,K, na
- LOGICAL :: predicate
-
- REAL :: da, eot ! jararias, 14/08/2013
-
-! begin WRF-CMAQ twoway coupled model block
-#if ( WRF_CMAQ == 1 )
- REAL, DIMENSION (3) :: INMASS_ws, & ! holds mass cocentrations in [ ug/m**3 ] for
- ! water soluble species in all three modes
- INMASS_in, & ! holds mass cocentrations in [ ug/m**3 ] for
- ! water insoluble species in all three modes
- INMASS_ec, & ! holds mass cocentrations in [ ug/m**3 ] for
- ! elemental carbon species in all three modes
- INMASS_ss, & ! holds mass cocentrations in [ ug/m**3 ] for
- ! aerosol water species in all three modes
- INMASS_h2o, & ! holds mass cocentrations in [ ug/m**3 ] for
- ! sea salt species in all three modes
- INDGN, & ! holds geometric mean diameter in all three modes
- INSIG ! holds geometric standard deviation in all three modes
-#endif
- REAL :: xtauaer, & ! temporary variable for Aerosol Optical Depth
- waer, & ! temporary variable for single scattering albedo
- gaer, & ! temporary variable for symmetry factor
- delta_z, & ! layer thickness
- loc_sw_zbbcddir, & ! clearsky downward direct shortwave flux (w/m2)
- loc_sw_dirdflux, & ! Direct downward shortwave surface flux
- loc_sw_difdflux ! Diffuse downward shortwave surface flux
-
- INTEGER :: modes ! number of modes
-
- character (len = 50) :: mystr ! temporary character string
-! end WRF-CMAQ twoway coupled model block
-
-!------------------------------------------------------------------
-! Annual function for co2 in WRF v4.2
- co2 = (280. + 90.*exp(0.02*(yr-2000)))*1.e-6
-#if ( WRF_CHEM == 1 )
- IF ( aer_ra_feedback == 1) then
- IF ( .NOT. &
- ( PRESENT(tauaer300) .AND. &
- PRESENT(tauaer400) .AND. &
- PRESENT(tauaer600) .AND. &
- PRESENT(tauaer999) .AND. &
- PRESENT(gaer300) .AND. &
- PRESENT(gaer400) .AND. &
- PRESENT(gaer600) .AND. &
- PRESENT(gaer999) .AND. &
- PRESENT(waer300) .AND. &
- PRESENT(waer400) .AND. &
- PRESENT(waer600) .AND. &
- PRESENT(waer999) ) ) THEN
- CALL wrf_error_fatal &
- ('Warning: missing fields required for aerosol radiation' )
- ENDIF
- ENDIF
-#endif
-
-!-----CALCULATE SHORT WAVE RADIATION
-!
-! All fields are ordered vertically from bottom to top
-! Pressures are in mb
-
-! latitude loop
- j_loop: do j = jts,jte
-
-! longitude loop
- i_loop: do i = its,ite
- rho1d(kts:kte)=rho3d(i,kts:kte,j) ! BUG FIX (SGT): this was uninitialized
-!
-! Do shortwave by default, deactivate below if sun below horizon
- dorrsw = .true.
-
-! Cosine solar zenith angle for current time step
-!
- ! jararias, 14/08/2013
- coszr(i,j)=xcoszen(i,j)
- coszrs=xcoszen(i,j)
-
-! Set flag to prevent shortwave calculation when sun below horizon
- if (coszrs.le.0.0) dorrsw = .false.
-! Perform shortwave calculation if sun above horizon
- if (dorrsw) then
-
- do k=kts,kte+1
- Pw1D(K) = p8w(I,K,J)/100.
- Tw1D(K) = t8w(I,K,J)
- enddo
-
- DO K=kts,kte
- QV1D(K)=0.
- QC1D(K)=0.
- QR1D(K)=0.
- QI1D(K)=0.
- QS1D(K)=0.
- CLDFRA1D(k)=0.
- QNDROP1D(k)=0.
- ENDDO
-
- DO K=kts,kte
- QV1D(K)=QV3D(I,K,J)
- QV1D(K)=max(0.,QV1D(K))
- ENDDO
-
- IF (PRESENT(O33D)) THEN
- DO K=kts,kte
- O31D(K)=O33D(I,K,J)
- ENDDO
- ELSE
- DO K=kts,kte
- O31D(K)=0.0
- ENDDO
- ENDIF
-
- DO K=kts,kte
- TTEN1D(K)=0.
- T1D(K)=t3d(I,K,J)
- P1D(K)=p3d(I,K,J)/100.
- DZ1D(K)=dz8w(I,K,J)
- ENDDO
-
-! moist variables
-
- IF (ICLOUD .ne. 0) THEN
- IF ( PRESENT( CLDFRA3D ) ) THEN
- DO K=kts,kte
- CLDFRA1D(k)=CLDFRA3D(I,K,J)
- ENDDO
- ENDIF
-
- IF (PRESENT(F_QC) .AND. PRESENT(QC3D)) THEN
- IF ( F_QC) THEN
- DO K=kts,kte
- QC1D(K)=QC3D(I,K,J)
- QC1D(K)=max(0.,QC1D(K))
- ENDDO
- ENDIF
- ENDIF
-
- IF (PRESENT(F_QR) .AND. PRESENT(QR3D)) THEN
- IF ( F_QR) THEN
- DO K=kts,kte
- QR1D(K)=QR3D(I,K,J)
- QR1D(K)=max(0.,QR1D(K))
- ENDDO
- ENDIF
- ENDIF
-
- IF ( PRESENT(F_QNDROP).AND.PRESENT(QNDROP3D)) THEN
- IF (F_QNDROP) THEN
- DO K=kts,kte
- qndrop1d(K)=qndrop3d(I,K,J)
- ENDDO
- ENDIF
- ENDIF
-
-! This logic is tortured because cannot test F_QI unless
-! it is present, and order of evaluation of expressions
-! is not specified in Fortran
-
- IF ( PRESENT ( F_QI ) ) THEN
- predicate = F_QI
- ELSE
- predicate = .FALSE.
- ENDIF
-
-! For MP option 3
- IF (.NOT. predicate .and. .not. warm_rain) THEN
- DO K=kts,kte
- IF (T1D(K) .lt. 273.15) THEN
- QI1D(K)=QC1D(K)
- QS1D(K)=QR1D(K)
- QC1D(K)=0.
- QR1D(K)=0.
- ENDIF
- ENDDO
- ENDIF
-
- IF (PRESENT(F_QI) .AND. PRESENT(QI3D)) THEN
- IF (F_QI) THEN
- DO K=kts,kte
- QI1D(K)=QI3D(I,K,J)
- QI1D(K)=max(0.,QI1D(K))
- ENDDO
- ENDIF
- ENDIF
-
- IF (PRESENT(F_QS) .AND. PRESENT(QS3D)) THEN
- IF (F_QS) THEN
- DO K=kts,kte
- QS1D(K)=QS3D(I,K,J)
- QS1D(K)=max(0.,QS1D(K))
- ENDDO
- ENDIF
- ENDIF
-
- IF (PRESENT(F_QG) .AND. PRESENT(QG3D)) THEN
- IF (F_QG) THEN
- DO K=kts,kte
- QG1D(K)=QG3D(I,K,J)
- QG1D(K)=max(0.,QG1D(K))
- ENDDO
- ENDIF
- ENDIF
-
-! mji - For MP option 5
- IF ( PRESENT(F_QI) .and. PRESENT(F_QC) .and. PRESENT(F_QS) .and. PRESENT(F_ICE_PHY) ) THEN
- IF ( F_QC .and. .not. F_QI .and. F_QS ) THEN
- DO K=kts,kte
- qi1d(k) = 0.1*qs3d(i,k,j)
- qs1d(k) = 0.9*qs3d(i,k,j)
- qc1d(k) = qc3d(i,k,j)
- qi1d(k) = max(0.,qi1d(k))
- qc1d(k) = max(0.,qc1d(k))
- ENDDO
- ENDIF
- ENDIF
-
- ENDIF
-! For mp option=5 or 85 (new Ferrier- Aligo or called fer_hires
-! scheme), QI3D saves all frozen water (ice+snow)
-#if (HWRF == 1)
- IF ( mp_physics == FER_MP_HIRES .OR. &
- mp_physics == FER_MP_HIRES_ADVECT .OR. &
- mp_physics == ETAMP_HWRF ) THEN
-#else
- IF ( mp_physics == FER_MP_HIRES .OR. &
- mp_physics == FER_MP_HIRES_ADVECT) THEN
-#endif
- DO K=kts,kte
- qi1d(k) = qi3d(i,k,j)
- qs1d(k) = 0.0
- qc1d(k) = qc3d(i,k,j)
- qi1d(k) = max(0.,qi1d(k))
- qc1d(k) = max(0.,qc1d(k))
- ENDDO
- ENDIF
-!
-! EMISS0=EMISS(I,J)
-! GLW0=0.
-! OLR0=0.
-! TSFC=TSK(I,J)
- DO K=kts,kte
- QV1D(K)=AMAX1(QV1D(K),1.E-12)
- ENDDO
-
-! Set up input for shortwave
- ncol = 1
-! Add extra layer from top of model to top of atmosphere
- nlay = (kte - kts + 1) + 1
-
-! Select cloud overlap assumption (1 = random, 2 = maximum-random, 3 = maximum, 4 = exponential, 5 = exponential-random
- icld=cldovrlp ! J. Henderson AER assign namelist variable cldovrlp to existing icld
-
-! Select cloud liquid and ice optics parameterization options
-! For passing in cloud optical properties directly:
-! inflgsw = 0
-! iceflgsw = 0
-! liqflgsw = 0
-! For passing in cloud physical properties; cloud optics parameterized in RRTMG:
- inflgsw = 2
- iceflgsw = 3
- liqflgsw = 1
-
-!Mukul change the flags here with reference to the new effective cloud/ice/snow radius
- IF (ICLOUD .ne. 0) THEN
- IF ( has_reqc .ne. 0) THEN
- inflgsw = 3
- DO K=kts,kte
- recloud1D(ncol,K) = MAX(2.5, re_cloud(I,K,J)*1.E6)
- if (recloud1D(ncol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. &
- & .AND. (XLAND(I,J)-1.5).GT.0.) then !--- Ocean
- recloud1D(ncol,K) = 10.5
- elseif (recloud1D(ncol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. &
- & .AND. (XLAND(I,J)-1.5).LT.0.) then !--- Land
- recloud1D(ncol,K) = 7.5
- endif
- ENDDO
- ELSE
- DO K=kts,kte
-#if (EM_CORE==1)
- recloud1D(ncol,K) = 5.0
-#else
- recloud1D(ncol,K) = 10.0 ! was 5.0
-#endif
- ENDDO
- ENDIF
-
- IF ( has_reqi .ne. 0) THEN
- inflgsw = 4
- iceflgsw = 4
- DO K=kts,kte
- reice1D(ncol,K) = MAX(5., re_ice(I,K,J)*1.E6)
- if (reice1D(ncol,K).LE.5..AND.cldfra3d(i,k,j).gt.0.) then
- idx_rei = int(t3d(i,k,j)-179.)
- idx_rei = min(max(idx_rei,1),75)
- corr = t3d(i,k,j) - int(t3d(i,k,j))
- reice1D(ncol,K) = retab(idx_rei)*(1.-corr) + &
- & retab(idx_rei+1)*corr
- reice1D(ncol,K) = MAX(reice1D(ncol,K), 5.0)
- endif
- ENDDO
- ELSE
- DO K=kts,kte
- reice1D(ncol,K) = 10.
- ENDDO
- ENDIF
-
- IF ( has_reqs .ne. 0) THEN
- inflgsw = 5
- iceflgsw = 5
- DO K=kts,kte
- resnow1D(ncol,K) = MAX(10., re_snow(I,K,J)*1.E6)
- ENDDO
- ELSE
- DO K=kts,kte
-#if (EM_CORE==1)
- resnow1D(ncol,K) = 10.0
-#else
- tem2 = 25.0 !- was 10.0
- tem3=1.e3*rho1d(k)*qi1d(k) !- IWC (g m^-3)
- if (tem3>thresh) then !- Only when IWC>1.e-9 g m^-3
- tem1=t1d(k)-273.15
- if (tem1 < -50.0) then
- tem2 = re_50C*tem3**0.109
- elseif (tem1 < -40.0) then
- tem2 = re_40C*tem3**0.08
- elseif (tem1 < -30.0) then
- tem2 = re_30C*tem3**0.055
- else
- tem2 = re_20C*tem3**0.031
- endif
- tem2 = max(25.,tem2)
- endif
- reice1D(ncol,K) = min(tem2, 135.72) !- 1.0315*reice <= 140 microns
-#endif
- ENDDO
- ENDIF
-
-! special case for P3 microphysics
-! put ice into snow category for optics, then set ice to zero
- IF ( has_reqs .eq. 0 .and. has_reqi .ne. 0 .and. has_reqc .ne. 0) THEN
- inflgsw = 5
- iceflgsw = 5
- DO K=kts,kte
- resnow1D(ncol,K) = MAX(10., re_ice(I,K,J)*1.E6)
- QS1D(K)=QI3D(I,K,J)
- QI1D(K)=0.
- reice1D(ncol,K)=10.
- END DO
-
- END IF
-
- ENDIF
-
-! Set cosine of solar zenith angle
- coszen(ncol) = coszrs
-! Set solar constant (original) amontornes-bcodina 2015/09
-! scon = solcon
-! amontornes-bcodina 2015/09 solar eclipses
- scon = solcon*(1-obscur(i,j))
-
-! For Earth/Sun distance adjustment in RRTMG
-! dyofyr = julday
-! adjes = 0.0
-! For WRF, solar constant is already provided with eccentricity adjustment,
-! so do not do this in RRTMG
- dyofyr = 0
- adjes = 1.0
-
-! Layer indexing goes bottom to top here for all fields.
-! Water vapor and ozone are converted from mmr to vmr.
-! Pressures are in units of mb here.
- plev(ncol,1) = pw1d(1)
- tlev(ncol,1) = tw1d(1)
- tsfc(ncol) = tsk(i,j)
- do k = kts, kte
- play(ncol,k) = p1d(k)
- plev(ncol,k+1) = pw1d(k+1)
- pdel(ncol,k) = plev(ncol,k) - plev(ncol,k+1)
- tlay(ncol,k) = t1d(k)
- tlev(ncol,k+1) = tw1d(k+1)
- h2ovmr(ncol,k) = qv1d(k) * amdw
- co2vmr(ncol,k) = co2
- o2vmr(ncol,k) = o2
- ch4vmr(ncol,k) = ch4
- n2ovmr(ncol,k) = n2o
- enddo
-
-! mji - Derive height of each layer mid-point from layer thickness.
-! Needed for exponential (icld=4) and exponential-random overlap option (icld=5) only.
- dzsum = 0.0
- do k = kts, kte
- dz = dz1d(k)
- hgt(ncol,k) = dzsum + 0.5*dz
- dzsum = dzsum + dz
- enddo
-
-! Define profile values for extra layer from model top to top of atmosphere.
-! The top layer temperature for all gridpoints is set to the top layer-1
-! temperature plus a constant (0 K) that represents an isothermal layer
-! above ptop. Top layer interface temperatures are linearly interpolated
-! from the layer temperatures.
-
- play(ncol,kte+1) = 0.5 * plev(ncol,kte+1)
- tlay(ncol,kte+1) = tlev(ncol,kte+1) + 0.0
- plev(ncol,kte+2) = 1.0e-5
- tlev(ncol,kte+2) = tlev(ncol,kte+1) + 0.0
- tlev(ncol,kte+2) = tlev(ncol,kte+1) + 0.0
- h2ovmr(ncol,kte+1) = h2ovmr(ncol,kte)
- co2vmr(ncol,kte+1) = co2vmr(ncol,kte)
- o2vmr(ncol,kte+1) = o2vmr(ncol,kte)
- ch4vmr(ncol,kte+1) = ch4vmr(ncol,kte)
- n2ovmr(ncol,kte+1) = n2ovmr(ncol,kte)
-
-! mji - Fill in height array above model top to top of atmosphere using
-! dz from model top layer for completeness, though this information is not
-! likely to be used by the exponential-random cloud overlap method.
- hgt(ncol,kte+1) = dzsum + 0.5*dz
-
-! Get ozone profile including amount in extra layer above model top
- call inirad (o3mmr,plev,kts,kte)
-
- if(present(o33d)) then
- do k = kts, kte+1
- o3vmr(ncol,k) = o3mmr(k) * amdo
- IF ( PRESENT( O33D ) ) THEN
- if(o3input .eq. 2)then
- if(k.le.kte)then
- o3vmr(ncol,k) = o31d(k)
- else
-! apply shifted climatology profile above model top
- o3vmr(ncol,k) = o31d(kte) - o3mmr(kte)*amdo + o3mmr(k)*amdo
- if(o3vmr(ncol,k) .le. 0.)o3vmr(ncol,k) = o3mmr(k)*amdo
- endif
- endif
- ENDIF
- enddo
- else
- do k = kts, kte+1
- o3vmr(ncol,k) = o3mmr(k) * amdo
- enddo
- endif
-
-! Set surface albedo for direct and diffuse radiation in UV/visible and
-! near-IR spectral regions
-! -------------- Zhenxin 2011-06-20 ----------- !
-
-! ------- 1. Commented by Zhenxin 2011-06-20 for SSiB coupling modified ---- !
-! asdir(ncol) = albedo(i,j)
-! asdif(ncol) = albedo(i,j)
-! aldir(ncol) = albedo(i,j)
-! aldif(ncol) = albedo(i,j)
-! ------- End of Comments ------ !
-
-! ------- 2. New Addiation ------ !
- IF ( sf_surface_physics .eq. 8 .AND. XLAND(i,j) .LT. 1.5) THEN
- asdir(ncol) = ALSWVISDIR(I,J)
- asdif(ncol) = ALSWVISDIF(I,J)
- aldir(ncol) = ALSWNIRDIR(I,J)
- aldif(ncol) = ALSWNIRDIF(I,J)
- ELSE
- asdir(ncol) = albedo(i,j)
- asdif(ncol) = albedo(i,j)
- aldir(ncol) = albedo(i,j)
- aldif(ncol) = albedo(i,j)
- ENDIF
-
-! ---------- End of Addiation ------!
-! ---------- End of fds_Zhenxin 2011-06-20 --------------!
-
-! Define cloud optical properties for radiation (inflgsw = 0)
-! This option is not currently active
-! Cloud and precipitation paths in g/m2
-! qi=0 if no ice phase
-! qs=0 if no ice phase
- if (inflgsw .eq. 0) then
-
-! Set cloud fraction and cloud optical properties here; not yet active
- do k = kts, kte
- cldfrac(ncol,k) = cldfra1d(k)
- do nb = 1, nbndsw
- taucld(nb,ncol,k) = 0.0
- ssacld(nb,ncol,k) = 1.0
- asmcld(nb,ncol,k) = 0.0
- fsfcld(nb,ncol,k) = 0.0
- enddo
- enddo
-
-! Zero out cloud physical property arrays; not used when passing optical properties
-! into radiation
- do k = kts, kte
- clwpth(ncol,k) = 0.0
- ciwpth(ncol,k) = 0.0
- rel(ncol,k) = 10.0
- rei(ncol,k) = 10.
- enddo
- endif
-
-! Define cloud physical properties for radiation (inflgsw = 1 or 2)
-! Cloud fraction
-! Set cloud arrays if passing cloud physical properties into radiation
- if (inflgsw .gt. 0) then
- do k = kts, kte
- cldfrac(ncol,k) = cldfra1d(k)
- enddo
-
-! Compute cloud water/ice paths and particle sizes for input to radiation (CAM method)
- pcols = ncol
- pver = kte - kts + 1
- gravmks = g
- landfrac(ncol) = 2.-XLAND(I,J)
- landm(ncol) = landfrac(ncol)
- snowh(ncol) = 0.001*SNOW(I,J)
- icefrac(ncol) = XICE(I,J)
-
-! From module_ra_cam: Convert liquid and ice mixing ratios to water paths;
-! pdel is in mb here; convert back to Pa (*100.)
-! Water paths are in units of g/m2
-! snow added as ice cloud (JD 091022)
- do k = kts, kte
- gicewp = (qi1d(k)+qs1d(k)) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path.
- gliqwp = qc1d(k) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box liquid water path.
- cicewp(ncol,k) = gicewp / max(0.01,cldfrac(ncol,k)) ! In-cloud ice water path.
- cliqwp(ncol,k) = gliqwp / max(0.01,cldfrac(ncol,k)) ! In-cloud liquid water path.
- end do
-
-! Mukul
-!..The ice water path is already sum of cloud ice and snow, but when we have explicit
-!.. ice effective radius, overwrite the ice path with only the cloud ice variable,
-!.. leaving out the snow for its own effect.
- if(iceflgsw.ge.4)then
- do k = kts, kte
- gicewp = qi1d(k) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path.
- cicewp(ncol,k) = gicewp / max(0.01,cldfrac(ncol,k)) ! In-cloud ice water path.
- end do
- end if
-
-!..Here the snow path is adjusted if (radiation) effective radius of snow is
-!.. larger than what we currently have in the lookup tables. Since mass goes
-!.. rather close to diameter squared, adjust the mixing ratio of snow used
-!.. to compute its water path in combination with the max diameter. Not a
-!.. perfect fix, but certainly better than using all snow mass when diameter is
-!.. far larger than table currently contains and crystal sizes much larger than
-!.. about 140 microns have lesser impact than those much smaller sizes.
-
- if(iceflgsw.eq.5)then
- do k = kts, kte
- snow_mass_factor = 1.0
- if (resnow1d(ncol,k) .gt. 130.)then
- snow_mass_factor = (130.0/resnow1d(ncol,k))*(130.0/resnow1d(ncol,k))
- resnow1d(ncol,k) = 130.0
- endif
- gsnowp = qs1d(k) * snow_mass_factor * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box snow water path.
- csnowp(ncol,k) = gsnowp / max(0.01,cldfrac(ncol,k))
- end do
- end if
-
-
-!link the aerosol feedback to cloud -czhao
- if( PRESENT( progn ) ) then
- if (progn == 1) then
-!jdfcz if(prescribe==0) then
-
- pi = 4.*atan(1.0)
- third=1./3.
- rhoh2o=1.e3
- relconst=3/(4.*pi*rhoh2o)
-! minimun liquid water path to calculate rel
-! corresponds to optical depth of 1.e-3 for radius 4 microns.
- lwpmin=3.e-5
- do k = kts, kte
- reliq(ncol,k) = 10.
- if( PRESENT( F_QNDROP ) ) then
- if( F_QNDROP ) then
- if ( qc1d(k)*pdel(ncol,k).gt.lwpmin.and. &
- qndrop1d(k).gt.1000. ) then
- reliq(ncol,k)=(relconst*qc1d(k)/qndrop1d(k))**third ! effective radius in m
-! apply scaling from Martin et al., JAS 51, 1830.
- reliq(ncol,k)=1.1*reliq(ncol,k)
- reliq(ncol,k)=reliq(ncol,k)*1.e6 ! convert from m to microns
- reliq(ncol,k)=max(reliq(ncol,k),4.)
- reliq(ncol,k)=min(reliq(ncol,k),20.)
- end if
- end if
- end if
- end do
-!jdfcz else ! prescribe
-! following Kiehl
-! call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
-! write(0,*) 'sw prescribe aerosol',maxval(qndrop3d)
-!jdfcz endif
- else ! progn (progn=1)
- call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
- endif
- else !progn (PRESENT)
- call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
- endif
-
-! following Kristjansson and Mitchell
- call reicalc(ncol, pcols, pver, tlay, reice)
-
-
-
-!..If we already have effective radius of cloud and ice, then just overwrite what
-!.. was computed in the relcalc and reicalc subroutines above.
-
- if (inflgsw .ge. 3) then
- do k = kts, kte
- reliq(ncol,k) = recloud1d(ncol,k)
- end do
- endif
-#if (EM_CORE==1)
- if (iceflgsw .ge. 4) then
-#else
- if (iceflgsw .ge. 3) then !BSF: was .ge. 4
-#endif
- do k = kts, kte
- reice(ncol,k) = reice1d(ncol,k)
- end do
- endif
-
-
-#if 0
- if (i==80.and.j==30) then
-#if defined( DM_PARALLEL ) && ! defined( STUBMPI)
- if( PRESENT( progn ) ) write(0,*) 'aerosol indirect',progn
- write(0,*)'sw water eff radius',reliq(ncol,10),reliq(ncol,20),reliq(ncol,25)
- write(0,*)'sw ice eff radius',reice(ncol,10),reice(ncol,20),reice(ncol,25)
-#endif
- endif
-#endif
-
-
-! Limit upper bound of reice for Fu ice parameterization and convert
-! from effective radius to generalized effective size (*1.0315; Fu, 1996)
- if (iceflgsw .eq. 3) then
- do k = kts, kte
- reice(ncol,k) = reice(ncol,k) * 1.0315
- reice(ncol,k) = min(140.0,reice(ncol,k))
- end do
- endif
-
-!if CAMMGMP is used, use output from CAMMGMP
-!PMA
- if(is_CAMMGMP_used) then
- do k = kts, kte
- if ( qi1d(k) .gt. 1.e-20 .or. qs1d(k) .gt. 1.e-20) then
- reice(ncol,k) = iradius(i,k,j)
- else
- reice(ncol,k) = 25.
- end if
- reice(ncol,k) = max(5., min(140.0,reice(ncol,k)))
- if ( qc1d(k) .gt. 1.e-20) then
- reliq(ncol,k) = lradius(i,k,j)
- else
- reliq(ncol,k) = 10.
- end if
- reliq(ncol,k) = max(2.5, min(60.0,reliq(ncol,k)))
- enddo
- endif
-
-! Set cloud physical property arrays
- do k = kts, kte
- clwpth(ncol,k) = cliqwp(ncol,k)
- ciwpth(ncol,k) = cicewp(ncol,k)
- rel(ncol,k) = reliq(ncol,k)
- rei(ncol,k) = reice(ncol,k)
- enddo
-
-!Mukul
- if (inflgsw .eq. 5) then
- do k = kts, kte
- cswpth(ncol,k) = csnowp(ncol,k)
- res(ncol,k) = resnow1d(ncol,k)
- end do
- else
- do k = kts, kte
- cswpth(ncol,k) = 0.0
- res(ncol,k) = 10.0
- end do
- endif
-
-! Zero out cloud optical properties here, calculated in radiation
- do k = kts, kte
- do nb = 1, nbndsw
- taucld(nb,ncol,k) = 0.0
- ssacld(nb,ncol,k) = 1.0
- asmcld(nb,ncol,k) = 0.0
- fsfcld(nb,ncol,k) = 0.0
- enddo
- enddo
- endif
-
-! No clouds are allowed in the extra layer from model top to TOA
- clwpth(ncol,kte+1) = 0.
- ciwpth(ncol,kte+1) = 0.
- cswpth(ncol,kte+1) = 0.
- rel(ncol,kte+1) = 10.
- rei(ncol,kte+1) = 10.
- res(ncol,kte+1) = 10.
- cldfrac(ncol,kte+1) = 0.
- do nb = 1, nbndsw
- taucld(nb,ncol,kte+1) = 0.
- ssacld(nb,ncol,kte+1) = 1.
- asmcld(nb,ncol,kte+1) = 0.
- fsfcld(nb,ncol,kte+1) = 0.
- enddo
-
- iplon = 1
- irng = 0
- permuteseed = 1
-
-! Sub-column generator for McICA
-! mji - Add layer height needed for exponential (icld=4) and exponential-random (icld=5) overlap options
- call mcica_subcol_sw(iplon, ncol, nlay, icld, permuteseed, irng, play, hgt, &
- cldfrac, ciwpth, clwpth, cswpth, rei, rel, res, taucld, ssacld, asmcld, fsfcld, &
- cldfmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, &
- taucmcl, ssacmcl, asmcmcl, fsfcmcl)
-
-
-!--------------------------------------------------------------------------
-! Aerosol optical depth, single scattering albedo and asymmetry parameter -czhao 03/2010
-!--------------------------------------------------------------------------
-! by layer for each RRTMG shortwave band
-! No aerosols in top layer above model top (kte+1).
-!cz do nb = 1, nbndsw
-!cz do k = kts, kte+1
-!cz tauaer(ncol,k,nb) = 0.
-!cz ssaaer(ncol,k,nb) = 1.
-!cz asmaer(ncol,k,nb) = 0.
-!cz enddo
-!cz enddo
-
-! ... Aerosol effects. Added aerosol feedbacks from Chem , 03/2010 -czhao
-!
-#if ( WRF_CMAQ == 1 )
- do nb = 1, nbndsw
- do k = kts,kte+1
- tauaer(ncol,k,nb) = 0.
- ssaaer(ncol,k,nb) = 1.
- asmaer(ncol,k,nb) = 0.
-
- if (proceed_twoway_sw) then
- INMASS_ws(1) = mass_ws_i(i,k,j)
- INMASS_ws(2) = mass_ws_j(i,k,j)
- INMASS_ws(3) = mass_ws_k(i,k,j)
- INMASS_in(1) = mass_in_i(i,k,j)
- INMASS_in(2) = mass_in_j(i,k,j)
- INMASS_in(3) = mass_in_k(i,k,j)
- INMASS_ec(1) = mass_ec_i(i,k,j)
- INMASS_ec(2) = mass_ec_j(i,k,j)
- INMASS_ec(3) = mass_ec_k(i,k,j)
- INMASS_ss(1) = mass_ss_i(i,k,j)
- INMASS_ss(2) = mass_ss_j(i,k,j)
- INMASS_ss(3) = mass_ss_k(i,k,j)
- INMASS_h2o(1) = mass_h2o_i(i,k,j)
- INMASS_h2o(2) = mass_h2o_j(i,k,j)
- INMASS_h2o(3) = mass_h2o_k(i,k,j)
- INDGN(1) = dgn_i(i,k,j)
- INDGN(2) = dgn_j(i,k,j)
- INDGN(3) = dgn_k(i,k,j)
- INSIG(1) = sig_i(i,k,j)
- INSIG(2) = sig_j(i,k,j)
- INSIG(3) = sig_k(i,k,j)
-
- delta_z = dz8w(i,k,j)
-
- call get_aerosol_Optics_RRTMG_SW( nb,nmode,delta_z, &
- INMASS_ws, INMASS_in, INMASS_ec, INMASS_ss, &
- INMASS_h2o, INDGN, INSIG, &
- xtauaer, waer, gaer )
-
- write (mystr, *) xtauaer
- if (trim(mystr) == ' NaN') then
- write (6, '(a13, 2i5)') ' ==d== ', nb, nmode
- write (6, '(a13, 5e18.10)') ' ==d== delta ', delta_z
- write (6, '(a13, 5e18.10)') ' ==d== ws ', INMASS_ws
- write (6, '(a13, 5e18.10)') ' ==d== in ', INMASS_in
- write (6, '(a13, 5e18.10)') ' ==d== ec ', INMASS_ec
- write (6, '(a13, 5e18.10)') ' ==d== ss ', INMASS_ss
- write (6, '(a13, 5e18.10)') ' ==d== h2o ', INMASS_h2o
- write (6, '(a13, 5e18.10)') ' ==d== indgn ', INDGN
- write (6, '(a13, 5e18.10)') ' ==d== insig ', INSIG
- end if
-
- if (nb == 11) then
- gtauxar_01 (i,k,j) = xtauaer
- asy_fac_01 (i,k,j) = gaer
- ssa_01 (i,k,j) = waer
- else if (nb == 10) then
- gtauxar_02 (i,k,j) = xtauaer
- asy_fac_02 (i,k,j) = gaer
- ssa_02 (i,k,j) = waer
- else if (nb == 9) then
- gtauxar_03 (i,k,j) = xtauaer
- asy_fac_03 (i,k,j) = gaer
- ssa_03 (i,k,j) = waer
- else if (nb == 8) then
- gtauxar_04 (i,k,j) = xtauaer
- asy_fac_04 (i,k,j) = gaer
- ssa_04 (i,k,j) = waer
- else if (nb == 7) then
- gtauxar_05 (i,k,j) = xtauaer
- asy_fac_05 (i,k,j) = gaer
- ssa_05 (i,k,j) = waer
- end if
-
- tauaer(ncol,k,nb) = xtauaer
- ssaaer(ncol,k,nb) = waer
- asmaer(ncol,k,nb) = gaer
- end if
- enddo ! loop over layers
- if (proceed_twoway_sw) then
-! No aerosols in top layer above model top (kte+1).
- tauaer(ncol, kte+1 ,nb) = 0.
- ssaaer(ncol, kte+1 ,nb) = 1.
- asmaer(ncol, kte+1 ,nb) = 0.
- end if
- enddo ! loop over wavelengths
-#else
- do nb = 1, nbndsw
- do k = kts,kte+1
- tauaer(ncol,k,nb) = 0.
- ssaaer(ncol,k,nb) = 1.
- asmaer(ncol,k,nb) = 0.
- end do
- end do
-
- if ( associated (tauaer3d_sw) ) then
-! ---- jararias 11/2012
- do nb=1,nbndsw
- do k=kts,kte
- tauaer(ncol,k,nb)=tauaer3d_sw(i,k,j,nb)
- ssaaer(ncol,k,nb)=ssaaer3d_sw(i,k,j,nb)
- asmaer(ncol,k,nb)=asyaer3d_sw(i,k,j,nb)
- end do
- end do
- end if
-#endif
-
-#if ( WRF_CHEM == 1 )
- IF ( AER_RA_FEEDBACK == 1) then
- do nb = 1, nbndsw
- wavemid(nb)=0.5*(wavemin(nb)+wavemax(nb)) ! um
- do k = kts,kte !wig
-
-! convert optical properties at 300,400,600, and 999 to conform to the band wavelengths
-! tauaer - use angstrom exponent
- if(tauaer300(i,k,j).gt.thresh .and. tauaer999(i,k,j).gt.thresh) then
- ang=alog(tauaer300(i,k,j)/tauaer999(i,k,j))/alog(999./300.)
- tauaer(ncol,k,nb)=tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
- !tauaer(ncol,k,nb)=tauaer600(i,k,j)*(0.6/wavemid(nb))**ang
- if (i==30.and.j==49.and.k==2.and.nb==12) then
- write(0,*) 'TAU from 600 vs 400 in RRTMG',tauaer600(i,k,j),tauaer400(i,k,j)
- print*, 'TAU from 600 vs 400 in RRTMG',tauaer600(i,k,j),tauaer400(i,k,j)
- write(0,*) tauaer600(i,k,j)*(0.6/wavemid(nb))**ang,tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
- print*, tauaer600(i,k,j)*(0.6/wavemid(nb))**ang,tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
- endif
-! ssa - linear interpolation; extrapolation
- slope=(waer600(i,k,j)-waer400(i,k,j))/.2
- ssaaer(ncol,k,nb) = slope*(wavemid(nb)-.6)+waer600(i,k,j)
- if(ssaaer(ncol,k,nb).lt.0.4) ssaaer(ncol,k,nb)=0.4
- if(ssaaer(ncol,k,nb).ge.1.0) ssaaer(ncol,k,nb)=1.0
-! g - linear interpolation;extrapolation
- slope=(gaer600(i,k,j)-gaer400(i,k,j))/.2
- asmaer(ncol,k,nb) = slope*(wavemid(nb)-.6)+gaer600(i,k,j) ! notice reversed varaibles
- if(asmaer(ncol,k,nb).lt.0.5) asmaer(ncol,k,nb)=0.5
- if(asmaer(ncol,k,nb).ge.1.0) asmaer(ncol,k,nb)=1.0
- endif
- end do ! k
- end do ! nb
-
-!wig beg
- do nb = 1, nbndsw
- slope = 0. !use slope as a sum holder
- do k = kts,kte
- slope = slope + tauaer(ncol,k,nb)
- end do
- if( slope < 0. ) then
- write(msg,'("ERROR: Negative total optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb
- call wrf_error_fatal(msg)
- else if( slope > 6. ) then
- call wrf_message("-------------------------")
- write(msg,'("WARNING: Large total sw optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb
- call wrf_message(msg)
-
- call wrf_message("Diagnostics 1: k, tauaer300, tauaer400, tauaer600, tauaer999, tauaer")
- do k=kts,kte
- write(msg,'(i4,5f8.2)') k, tauaer300(i,k,j), tauaer400(i,k,j), &
- tauaer600(i,k,j), tauaer999(i,k,j),tauaer(ncol,k,nb)
- call wrf_message(msg)
- !czhao set an up-limit here to avoid segmentation fault
- !from extreme AOD
- tauaer(ncol,k,nb)=tauaer(ncol,k,nb)*6.0/slope
- end do
-
- call wrf_message("Diagnostics 2: k, gaer300, gaer400, gaer600, gaer999")
- do k=kts,kte
- write(msg,'(i4,4f8.2)') k, gaer300(i,k,j), gaer400(i,k,j), &
- gaer600(i,k,j), gaer999(i,k,j)
- call wrf_message(msg)
- end do
-
- call wrf_message("Diagnostics 3: k, waer300, waer400, waer600, waer999")
- do k=kts,kte
- write(msg,'(i4,4f8.2)') k, waer300(i,k,j), waer400(i,k,j), &
- waer600(i,k,j), waer999(i,k,j)
- call wrf_message(msg)
- end do
-
- call wrf_message("Diagnostics 4: k, ssaal, asyal, taual")
- do k=kts-1,kte
- write(msg,'(i4,3f8.2)') k, ssaaer(i,k,nb), asmaer(i,k,nb), tauaer(i,k,nb)
- call wrf_message(msg)
- end do
- call wrf_message("-------------------------")
- endif
- enddo ! nb
- endif ! aer_ra_feedback
-#endif
-
-
-! Zero array for input of aerosol optical thickness for use with
-! ECMWF aerosol types (not used)
- do na = 1, naerec
- do k = kts, kte+1
- ecaer(ncol,k,na) = 0.
- enddo
- enddo
-
- IF ( PRESENT( aerod ) ) THEN
- if ( aer_opt .eq. 0 ) then
- do na = 1, naerec
- do k = kts, kte+1
- ecaer(ncol,k,na) = 0.
- enddo
- enddo
- else if ( aer_opt .eq. 1 ) then
- do na = 1, naerec
- do k = kts, kte
- ecaer(ncol,k,na) = aerod(i,k,j,na)
- enddo
-! assuming 0 or same value at the top?
-! ecaer(ncol,kte+1,na) = ecaer(ncol,kte,na)
- ecaer(ncol,kte+1,na) = 0.
- enddo
- endif
- ENDIF
-
-! Call RRTMG shortwave radiation model
-
- call rrtmg_sw &
- (ncol ,nlay ,icld , &
- play ,plev ,tlay ,tlev ,tsfc , &
- h2ovmr , o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , &
- asdir ,asdif ,aldir ,aldif , &
- coszen ,adjes ,dyofyr ,scon , &
- inflgsw ,iceflgsw,liqflgsw,cldfmcl , &
- taucmcl ,ssacmcl ,asmcmcl ,fsfcmcl , &
- ciwpmcl ,clwpmcl ,cswpmcl, reicmcl ,relqmcl ,resnmcl, &
- tauaer ,ssaaer ,asmaer ,ecaer , &
- swuflx ,swdflx ,swhr ,swuflxc ,swdflxc ,swhrc, swuflxcln, swdflxcln, aer_opt, &
-! ----- Zhenxin added for ssib coupiling 2011-06-20 --------!
- sibvisdir, sibvisdif, sibnirdir, sibnirdif, &
-! -------------------- End of addiation by Zhenxin 2011-06-20 ------!
- swdkdir, swdkdif, & ! jararias, 2012/08/10
- swdkdirc & ! PAJ
- ,calc_clean_atm_diag &
- ,loc_sw_zbbcddir & ! WRF-CMAQ twoway coupled model
- ,loc_sw_dirdflux & ! WRF-CMAQ twoway coupled model
- ,loc_sw_difdflux & ! WRF-CMAQ twoway coupled model
- )
-
- ! WRF-CMAQ twoway coupled model
- if (present(sw_zbbcddir)) then
- sw_zbbcddir(i,j) = loc_sw_zbbcddir
- sw_dirdflux(i,j) = loc_sw_dirdflux
- sw_difdflux(i,j) = loc_sw_difdflux
- end if
-
-! Output net absorbed shortwave surface flux and shortwave cloud forcing
-! at the top of atmosphere (W/m2)
- gsw(i,j) = swdflx(1,1) - swuflx(1,1)
- swcf(i,j) = (swdflx(1,kte+2) - swuflx(1,kte+2)) - (swdflxc(1,kte+2) - swuflxc(1,kte+2))
-
- if (present(swupt)) then
-! Output up and down toa fluxes for total and clear sky
- swupt(i,j) = swuflx(1,kte+2)
- swuptc(i,j) = swuflxc(1,kte+2)
- swdnt(i,j) = swdflx(1,kte+2)
- swdntc(i,j) = swdflxc(1,kte+2)
-! Output up and down surface fluxes for total and clear sky
- swupb(i,j) = swuflx(1,1)
- swupbc(i,j) = swuflxc(1,1)
- swdnb(i,j) = swdflx(1,1)
-! Added by Zhenxin for 4 compenants of swdown radiation
- swvisdir(i,j) = sibvisdir(1,1)
- swvisdif(i,j) = sibvisdif(1,1)
- swnirdir(i,j) = sibnirdir(1,1)
- swnirdif(i,j) = sibnirdif(1,1)
-! Ended, Zhenxin (2011/06/20)
- swdnbc(i,j) = swdflxc(1,1)
- if(calc_clean_atm_diag .gt. 0)then
- swuptcln(i,j) = swuflxcln(1,kte+2)
- swdntcln(i,j) = swdflxcln(1,kte+2)
- swupbcln(i,j) = swuflxcln(1,1)
- swdnbcln(i,j) = swdflxcln(1,1)
- end if
- endif
- swddir(i,j) = swdkdir(1,1) ! jararias 2013/08/10
- swddni(i,j) = swddir(i,j) / coszrs ! jararias 2013/08/10
- swddif(i,j) = swdkdif(1,1) ! jararias 2013/08/10
- swdownc(i, j) = swdflxc(1,1) ! PAJ: clear-sky GHI
- swddirc(i,j) = swdkdirc(1,1) ! PAJ: clear-sky direct normal irradiance
- swddnic(i,j) = swddirc(i,j) / coszrs ! PAJ: clear-sky direct normal irradiance
-
-! Output up and down layer fluxes for total and clear sky.
-! Vertical ordering is from bottom to top in units of W m-2.
- if ( present (swupflx) ) then
- do k=kts,kte+2
- swupflx(i,k,j) = swuflx(1,k)
- swupflxc(i,k,j) = swuflxc(1,k)
- swdnflx(i,k,j) = swdflx(1,k)
- swdnflxc(i,k,j) = swdflxc(1,k)
- enddo
- endif
-
-! Output heating rate tendency; convert heating rate from K/d to K/s
-! Heating rate arrays are ordered vertically from bottom to top here.
- do k=kts,kte
- tten1d(k) = swhr(ncol,k)/86400.
- rthratensw(i,k,j) = tten1d(k)/pi3d(i,k,j)
- tten1d(k) = swhrc(ncol,k)/86400.
- rthratenswc(i,k,j) = tten1d(k)/pi3d(i,k,j)
- enddo
- else
- if (proceed_twoway_sw) then ! this is for WRF-CMAQ twoway coupled model
- gtauxar_01 (i,:,j) = 0.0
- gtauxar_02 (i,:,j) = 0.0
- gtauxar_03 (i,:,j) = 0.0
- gtauxar_04 (i,:,j) = 0.0
- gtauxar_05 (i,:,j) = 0.0
- asy_fac_01 (i,:,j) = 0.0
- asy_fac_02 (i,:,j) = 0.0
- asy_fac_03 (i,:,j) = 0.0
- asy_fac_04 (i,:,j) = 0.0
- asy_fac_05 (i,:,j) = 0.0
- ssa_01 (i,:,j) = 0.0
- ssa_02 (i,:,j) = 0.0
- ssa_04 (i,:,j) = 0.0
- ssa_04 (i,:,j) = 0.0
- ssa_05 (i,:,j) = 0.0
- end if
-
- if (present(swupt)) then
-! Output up and down toa fluxes for total and clear sky
- swupt(i,j) = 0.
- swuptc(i,j) = 0.
- swdnt(i,j) = 0.
- swdntc(i,j) = 0.
-! Output up and down surface fluxes for total and clear sky
- swupb(i,j) = 0.
- swupbc(i,j) = 0.
- swdnb(i,j) = 0.
- swdnbc(i,j) = 0.
- swvisdir(i,j) = 0. ! Add by Zhenxin (2011/06/20)
- swvisdif(i,j) = 0.
- swnirdir(i,j) = 0.
- swnirdif(i,j) = 0. ! Add by Zhenxin (2011/06/20)
- if(calc_clean_atm_diag .gt. 0)then
- swuptcln(i,j) = 0.
- swdntcln(i,j) = 0.
- swupbcln(i,j) = 0.
- swdnbcln(i,j) = 0.
- end if
- endif
- swddir(i,j) = 0. ! jararias 2013/08/10
- swddni(i,j) = 0. ! jararias 2013/08/10
- swddif(i,j) = 0. ! jararias 2013/08/10
- swdownc(i, j) = 0.0 ! PAJ
- swddnic(i,j) = 0.0 ! PAJ
- swddirc(i,j) = 0.0 ! PAJ
- swcf(i,j) = 0.
-
- endif
-!
- end do i_loop
- end do j_loop
-
-
-!-------------------------------------------------------------------
-
- END SUBROUTINE RRTMG_SWRAD
-
-
-!====================================================================
- SUBROUTINE rrtmg_swinit( &
- allowed_to_read , &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
-!--------------------------------------------------------------------
- IMPLICIT NONE
-!--------------------------------------------------------------------
-
- LOGICAL , INTENT(IN) :: allowed_to_read
- INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte
-
-! Read in absorption coefficients and other data
- IF ( allowed_to_read ) THEN
- CALL rrtmg_swlookuptable
- ENDIF
-
-! Perform g-point reduction and other initializations
-! Specific heat of dry air (cp) used in flux to heating rate conversion factor.
- call rrtmg_sw_ini(cp)
-
- END SUBROUTINE rrtmg_swinit
-
-
-! **************************************************************************
- SUBROUTINE rrtmg_swlookuptable
-! **************************************************************************
-
-IMPLICIT NONE
-
-! Local
- INTEGER :: i
- LOGICAL :: opened
- LOGICAL , EXTERNAL :: wrf_dm_on_monitor
-
- CHARACTER*80 errmess
- INTEGER rrtmg_unit
-
- IF ( wrf_dm_on_monitor() ) THEN
- DO i = 10,99
- INQUIRE ( i , OPENED = opened )
- IF ( .NOT. opened ) THEN
- rrtmg_unit = i
- GOTO 2010
- ENDIF
- ENDDO
- rrtmg_unit = -1
- 2010 CONTINUE
- ENDIF
- CALL wrf_dm_bcast_bytes ( rrtmg_unit , IWORDSIZE )
- IF ( rrtmg_unit < 0 ) THEN
- CALL wrf_error_fatal ( 'module_ra_rrtmg_sw: rrtm_swlookuptable: Can not '// &
- 'find unused fortran unit to read in lookup table.' )
- ENDIF
-
- IF ( wrf_dm_on_monitor() ) THEN
- OPEN(rrtmg_unit,FILE='RRTMG_SW_DATA', &
- FORM='UNFORMATTED',STATUS='OLD',ERR=9009)
- ENDIF
-
- call sw_kgb16(rrtmg_unit)
- call sw_kgb17(rrtmg_unit)
- call sw_kgb18(rrtmg_unit)
- call sw_kgb19(rrtmg_unit)
- call sw_kgb20(rrtmg_unit)
- call sw_kgb21(rrtmg_unit)
- call sw_kgb22(rrtmg_unit)
- call sw_kgb23(rrtmg_unit)
- call sw_kgb24(rrtmg_unit)
- call sw_kgb25(rrtmg_unit)
- call sw_kgb26(rrtmg_unit)
- call sw_kgb27(rrtmg_unit)
- call sw_kgb28(rrtmg_unit)
- call sw_kgb29(rrtmg_unit)
-
- IF ( wrf_dm_on_monitor() ) CLOSE (rrtmg_unit)
-
- RETURN
-9009 CONTINUE
- WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error opening RRTMG_SW_DATA on unit ',rrtmg_unit
- CALL wrf_error_fatal(errmess)
-
- END SUBROUTINE rrtmg_swlookuptable
-
-! **************************************************************************
-! RRTMG Shortwave Radiative Transfer Model
-! Atmospheric and Environmental Research, Inc., Cambridge, MA
-!
-! Original by J.Delamere, Atmospheric & Environmental Research.
-! Reformatted for F90: JJMorcrette, ECMWF
-! Revision for GCMs: Michael J. Iacono, AER, July 2002
-! Further F90 reformatting: Michael J. Iacono, AER, June 2006
-!
-! This file contains 14 READ statements that include the
-! absorption coefficients and other data for each of the 14 shortwave
-! spectral bands used in RRTMG_SW. Here, the data are defined for 16
-! g-points, or sub-intervals, per band. These data are combined and
-! weighted using a mapping procedure in module RRTMG_SW_INIT to reduce
-! the total number of g-points from 224 to 112 for use in the GCM.
-! **************************************************************************
-
-! **************************************************************************
- subroutine sw_kgb16(rrtmg_unit)
-! **************************************************************************
-
- use rrsw_kg16, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
- rayl, strrat1, layreffr
-
- implicit none
- save
-
-! Input
- integer, intent(in) :: rrtmg_unit
-
-! Local
- character*80 errmess
- logical, external :: wrf_dm_on_monitor
-
-! Array sfluxrefo contains the Kurucz solar source function for this band.
-
-! Array rayl contains the Rayleigh extinction coefficient at v = 2925 cm-1.
-
-! The array KAO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels> ~100mb, temperatures, and binary
-! species parameters (see taumol.f for definition). The first
-! index in the array, JS, runs from 1 to 9, and corresponds to
-! different values of the binary species parameter. For instance,
-! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
-! JS = 3 corresponds to the parameter value 2/8, etc. The second index
-! in the array, JT, which runs from 1 to 5, corresponds to different
-! temperatures. More specifically, JT = 3 means that the data are for
-! the reference temperature TREF for this pressure level, JT = 2 refers
-! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
-! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
-! to the JPth reference pressure level (see taumol.f for these levels
-! in mb). The fourth index, IG, goes from 1 to 16, and indicates
-! which g-interval the absorption coefficients are for.
-
-! The array KBO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels < ~100mb and temperatures. The first
-! index in the array, JT, which runs from 1 to 5, corresponds to
-! different temperatures. More specifically, JT = 3 means that the
-! data are for the reference temperature TREF for this pressure
-! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
-! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
-! The second index, JP, runs from 13 to 59 and refers to the JPth
-! reference pressure level (see taumol.f for the value of these
-! pressure levels in mb). The third index, IG, goes from 1 to 16,
-! and tells us which g-interval the absorption coefficients are for.
-
-! The array FORREFO contains the coefficient of the water vapor
-! foreign-continuum (including the energy term). The first
-! index refers to reference temperature (296,260,224,260) and
-! pressure (970,475,219,3 mbar) levels. The second index
-! runs over the g-channel (1 to 16).
-
-! The array SELFREFO contains the coefficient of the water vapor
-! self-continuum (including the energy term). The first index
-! refers to temperature in 7.2 degree increments. For instance,
-! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
-! etc. The second index runs over the g-channel (1 to 16).
-
-#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
-#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
-#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
-
- IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
- rayl, strrat1, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
- DM_BCAST_REAL(rayl)
- DM_BCAST_REAL(strrat1)
- DM_BCAST_INTEGER(layreffr)
- DM_BCAST_MACRO(kao)
- DM_BCAST_MACRO(kbo)
- DM_BCAST_MACRO(selfrefo)
- DM_BCAST_MACRO(forrefo)
- DM_BCAST_MACRO(sfluxrefo)
-
- RETURN
-9010 CONTINUE
- WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
- CALL wrf_error_fatal(errmess)
-
- end subroutine sw_kgb16
-
-! **************************************************************************
- subroutine sw_kgb17(rrtmg_unit)
-! **************************************************************************
-
- use rrsw_kg17, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
- rayl, strrat, layreffr
-
- implicit none
- save
-
-! Input
- integer, intent(in) :: rrtmg_unit
-
-! Local
- character*80 errmess
- logical, external :: wrf_dm_on_monitor
-
-! Array sfluxrefo contains the Kurucz solar source function for this band.
-
-! Array rayl contains the Rayleigh extinction coefficient at v = 3625 cm-1.
-
-! The array KAO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels> ~100mb, temperatures, and binary
-! species parameters (see taumol.f for definition). The first
-! index in the array, JS, runs from 1 to 9, and corresponds to
-! different values of the binary species parameter. For instance,
-! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
-! JS = 3 corresponds to the parameter value 2/8, etc. The second index
-! in the array, JT, which runs from 1 to 5, corresponds to different
-! temperatures. More specifically, JT = 3 means that the data are for
-! the reference temperature TREF for this pressure level, JT = 2 refers
-! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
-! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
-! to the JPth reference pressure level (see taumol.f for these levels
-! in mb). The fourth index, IG, goes from 1 to 16, and indicates
-! which g-interval the absorption coefficients are for.
-
-! The array KBO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels < ~100mb and temperatures. The first
-! index in the array, JT, which runs from 1 to 5, corresponds to
-! different temperatures. More specifically, JT = 3 means that the
-! data are for the reference temperature TREF for this pressure
-! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
-! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
-! The second index, JP, runs from 13 to 59 and refers to the JPth
-! reference pressure level (see taumol.f for the value of these
-! pressure levels in mb). The third index, IG, goes from 1 to 16,
-! and tells us which g-interval the absorption coefficients are for.
-
-! The array FORREFO contains the coefficient of the water vapor
-! foreign-continuum (including the energy term). The first
-! index refers to reference temperature (296,260,224,260) and
-! pressure (970,475,219,3 mbar) levels. The second index
-! runs over the g-channel (1 to 16).
-
-! The array SELFREFO contains the coefficient of the water vapor
-! self-continuum (including the energy term). The first index
-! refers to temperature in 7.2 degree increments. For instance,
-! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
-! etc. The second index runs over the g-channel (1 to 16).
-
-#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
-#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
-#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
-
- IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
- rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
- DM_BCAST_REAL(rayl)
- DM_BCAST_REAL(strrat)
- DM_BCAST_INTEGER(layreffr)
- DM_BCAST_MACRO(kao)
- DM_BCAST_MACRO(kbo)
- DM_BCAST_MACRO(selfrefo)
- DM_BCAST_MACRO(forrefo)
- DM_BCAST_MACRO(sfluxrefo)
-
- RETURN
-9010 CONTINUE
- WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
- CALL wrf_error_fatal(errmess)
-
- end subroutine sw_kgb17
-
-! **************************************************************************
- subroutine sw_kgb18(rrtmg_unit)
-! **************************************************************************
-
- use rrsw_kg18, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
- rayl, strrat, layreffr
-
- implicit none
- save
-
-! Input
- integer, intent(in) :: rrtmg_unit
-
-! Local
- character*80 errmess
- logical, external :: wrf_dm_on_monitor
-
-! Array sfluxrefo contains the Kurucz solar source function for this band.
-
-! Array rayl contains the Rayleigh extinction coefficient at v = 4325 cm-1.
-
-! The array KAO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels> ~100mb, temperatures, and binary
-! species parameters (see taumol.f for definition). The first
-! index in the array, JS, runs from 1 to 9, and corresponds to
-! different values of the binary species parameter. For instance,
-! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
-! JS = 3 corresponds to the parameter value 2/8, etc. The second index
-! in the array, JT, which runs from 1 to 5, corresponds to different
-! temperatures. More specifically, JT = 3 means that the data are for
-! the reference temperature TREF for this pressure level, JT = 2 refers
-! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
-! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
-! to the JPth reference pressure level (see taumol.f for these levels
-! in mb). The fourth index, IG, goes from 1 to 16, and indicates
-! which g-interval the absorption coefficients are for.
-
-! The array KBO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels < ~100mb and temperatures. The first
-! index in the array, JT, which runs from 1 to 5, corresponds to
-! different temperatures. More specifically, JT = 3 means that the
-! data are for the reference temperature TREF for this pressure
-! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
-! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
-! The second index, JP, runs from 13 to 59 and refers to the JPth
-! reference pressure level (see taumol.f for the value of these
-! pressure levels in mb). The third index, IG, goes from 1 to 16,
-! and tells us which g-interval the absorption coefficients are for.
-
-! The array FORREFO contains the coefficient of the water vapor
-! foreign-continuum (including the energy term). The first
-! index refers to reference temperature (296,260,224,260) and
-! pressure (970,475,219,3 mbar) levels. The second index
-! runs over the g-channel (1 to 16).
-
-! The array SELFREFO contains the coefficient of the water vapor
-! self-continuum (including the energy term). The first index
-! refers to temperature in 7.2 degree increments. For instance,
-! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
-! etc. The second index runs over the g-channel (1 to 16).
-
-#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
-#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
-#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
-
- IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
- rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
- DM_BCAST_REAL(rayl)
- DM_BCAST_REAL(strrat)
- DM_BCAST_INTEGER(layreffr)
- DM_BCAST_MACRO(kao)
- DM_BCAST_MACRO(kbo)
- DM_BCAST_MACRO(selfrefo)
- DM_BCAST_MACRO(forrefo)
- DM_BCAST_MACRO(sfluxrefo)
-
- RETURN
-9010 CONTINUE
- WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
- CALL wrf_error_fatal(errmess)
-
- end subroutine sw_kgb18
-
-! **************************************************************************
- subroutine sw_kgb19(rrtmg_unit)
-! **************************************************************************
-
- use rrsw_kg19, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
- rayl, strrat, layreffr
-
- implicit none
- save
-
-! Input
- integer, intent(in) :: rrtmg_unit
-
-! Local
- character*80 errmess
- logical, external :: wrf_dm_on_monitor
-
-! Array sfluxrefo contains the Kurucz solar source function for this band.
-
-! Array rayl contains the Rayleigh extinction coefficient at v = 4900 cm-1.
-
-! The array KAO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels> ~100mb, temperatures, and binary
-! species parameters (see taumol.f for definition). The first
-! index in the array, JS, runs from 1 to 9, and corresponds to
-! different values of the binary species parameter. For instance,
-! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
-! JS = 3 corresponds to the parameter value 2/8, etc. The second index
-! in the array, JT, which runs from 1 to 5, corresponds to different
-! temperatures. More specifically, JT = 3 means that the data are for
-! the reference temperature TREF for this pressure level, JT = 2 refers
-! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
-! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
-! to the JPth reference pressure level (see taumol.f for these levels
-! in mb). The fourth index, IG, goes from 1 to 16, and indicates
-! which g-interval the absorption coefficients are for.
-
-! The array KBO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels < ~100mb and temperatures. The first
-! index in the array, JT, which runs from 1 to 5, corresponds to
-! different temperatures. More specifically, JT = 3 means that the
-! data are for the reference temperature TREF for this pressure
-! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
-! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
-! The second index, JP, runs from 13 to 59 and refers to the JPth
-! reference pressure level (see taumol.f for the value of these
-! pressure levels in mb). The third index, IG, goes from 1 to 16,
-! and tells us which g-interval the absorption coefficients are for.
-
-! The array FORREFO contains the coefficient of the water vapor
-! foreign-continuum (including the energy term). The first
-! index refers to reference temperature (296,260,224,260) and
-! pressure (970,475,219,3 mbar) levels. The second index
-! runs over the g-channel (1 to 16).
-
-! The array SELFREFO contains the coefficient of the water vapor
-! self-continuum (including the energy term). The first index
-! refers to temperature in 7.2 degree increments. For instance,
-! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
-! etc. The second index runs over the g-channel (1 to 16).
-
-#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
-#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
-#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
-
- IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
- rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
- DM_BCAST_REAL(rayl)
- DM_BCAST_REAL(strrat)
- DM_BCAST_INTEGER(layreffr)
- DM_BCAST_MACRO(kao)
- DM_BCAST_MACRO(kbo)
- DM_BCAST_MACRO(selfrefo)
- DM_BCAST_MACRO(forrefo)
- DM_BCAST_MACRO(sfluxrefo)
-
- RETURN
-9010 CONTINUE
- WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
- CALL wrf_error_fatal(errmess)
-
- end subroutine sw_kgb19
-
-! **************************************************************************
- subroutine sw_kgb20(rrtmg_unit)
-! **************************************************************************
-
- use rrsw_kg20, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
- absch4o, rayl, layreffr
-
- implicit none
- save
-
-! Input
- integer, intent(in) :: rrtmg_unit
-
-! Local
- character*80 errmess
- logical, external :: wrf_dm_on_monitor
-
-! Array sfluxrefo contains the Kurucz solar source function for this band.
-
-! Array rayl contains the Rayleigh extinction coefficient at v = 5670 cm-1.
-
-! Array absch4o contains the absorption coefficients for methane.
-
-! The array KAO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels> ~100mb, temperatures, and binary
-! species parameters (see taumol.f for definition). The first
-! index in the array, JS, runs from 1 to 9, and corresponds to
-! different values of the binary species parameter. For instance,
-! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
-! JS = 3 corresponds to the parameter value 2/8, etc. The second index
-! in the array, JT, which runs from 1 to 5, corresponds to different
-! temperatures. More specifically, JT = 3 means that the data are for
-! the reference temperature TREF for this pressure level, JT = 2 refers
-! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
-! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
-! to the JPth reference pressure level (see taumol.f for these levels
-! in mb). The fourth index, IG, goes from 1 to 16, and indicates
-! which g-interval the absorption coefficients are for.
-
-! The array KBO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels < ~100mb and temperatures. The first
-! index in the array, JT, which runs from 1 to 5, corresponds to
-! different temperatures. More specifically, JT = 3 means that the
-! data are for the reference temperature TREF for this pressure
-! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
-! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
-! The second index, JP, runs from 13 to 59 and refers to the JPth
-! reference pressure level (see taumol.f for the value of these
-! pressure levels in mb). The third index, IG, goes from 1 to 16,
-! and tells us which g-interval the absorption coefficients are for.
-
-! The array FORREFO contains the coefficient of the water vapor
-! foreign-continuum (including the energy term). The first
-! index refers to reference temperature (296,260,224,260) and
-! pressure (970,475,219,3 mbar) levels. The second index
-! runs over the g-channel (1 to 16).
-
-! The array SELFREFO contains the coefficient of the water vapor
-! self-continuum (including the energy term). The first index
-! refers to temperature in 7.2 degree increments. For instance,
-! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
-! etc. The second index runs over the g-channel (1 to 16).
-
-#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
-#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
-#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
-
- IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
- rayl, layreffr, absch4o, kao, kbo, selfrefo, forrefo, sfluxrefo
- DM_BCAST_REAL(rayl)
- DM_BCAST_INTEGER(layreffr)
- DM_BCAST_MACRO(absch4o)
- DM_BCAST_MACRO(kao)
- DM_BCAST_MACRO(kbo)
- DM_BCAST_MACRO(selfrefo)
- DM_BCAST_MACRO(forrefo)
- DM_BCAST_MACRO(sfluxrefo)
-
- RETURN
-9010 CONTINUE
- WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
- CALL wrf_error_fatal(errmess)
-
- end subroutine sw_kgb20
-
-! **************************************************************************
- subroutine sw_kgb21(rrtmg_unit)
-! **************************************************************************
-
- use rrsw_kg21, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
- rayl, strrat, layreffr
-
- implicit none
- save
-
-! Input
- integer, intent(in) :: rrtmg_unit
-
-! Local
- character*80 errmess
- logical, external :: wrf_dm_on_monitor
-
-! Array sfluxrefo contains the Kurucz solar source function for this band.
-
-! Array rayl contains the Rayleigh extinction coefficient at v = 6925 cm-1.
-
-! The array KAO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels> ~100mb, temperatures, and binary
-! species parameters (see taumol.f for definition). The first
-! index in the array, JS, runs from 1 to 9, and corresponds to
-! different values of the binary species parameter. For instance,
-! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
-! JS = 3 corresponds to the parameter value 2/8, etc. The second index
-! in the array, JT, which runs from 1 to 5, corresponds to different
-! temperatures. More specifically, JT = 3 means that the data are for
-! the reference temperature TREF for this pressure level, JT = 2 refers
-! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
-! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
-! to the JPth reference pressure level (see taumol.f for these levels
-! in mb). The fourth index, IG, goes from 1 to 16, and indicates
-! which g-interval the absorption coefficients are for.
-
-! The array KBO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels < ~100mb and temperatures. The first
-! index in the array, JT, which runs from 1 to 5, corresponds to
-! different temperatures. More specifically, JT = 3 means that the
-! data are for the reference temperature TREF for this pressure
-! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
-! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
-! The second index, JP, runs from 13 to 59 and refers to the JPth
-! reference pressure level (see taumol.f for the value of these
-! pressure levels in mb). The third index, IG, goes from 1 to 16,
-! and tells us which g-interval the absorption coefficients are for.
-
-! The array FORREFO contains the coefficient of the water vapor
-! foreign-continuum (including the energy term). The first
-! index refers to reference temperature (296,260,224,260) and
-! pressure (970,475,219,3 mbar) levels. The second index
-! runs over the g-channel (1 to 16).
-
-! The array SELFREFO contains the coefficient of the water vapor
-! self-continuum (including the energy term). The first index
-! refers to temperature in 7.2 degree increments. For instance,
-! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
-! etc. The second index runs over the g-channel (1 to 16).
-
-#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
-#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
-#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
-
- IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
- rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
- DM_BCAST_REAL(rayl)
- DM_BCAST_REAL(strrat)
- DM_BCAST_INTEGER(layreffr)
- DM_BCAST_MACRO(kao)
- DM_BCAST_MACRO(kbo)
- DM_BCAST_MACRO(selfrefo)
- DM_BCAST_MACRO(forrefo)
- DM_BCAST_MACRO(sfluxrefo)
-
- RETURN
-9010 CONTINUE
- WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
- CALL wrf_error_fatal(errmess)
-
- end subroutine sw_kgb21
-
-! **************************************************************************
- subroutine sw_kgb22(rrtmg_unit)
-! **************************************************************************
-
- use rrsw_kg22, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
- rayl, strrat, layreffr
-
- implicit none
- save
-
-! Input
- integer, intent(in) :: rrtmg_unit
-
-! Local
- character*80 errmess
- logical, external :: wrf_dm_on_monitor
-
-! Array sfluxrefo contains the Kurucz solar source function for this band.
-
-! Array rayl contains the Rayleigh extinction coefficient at v = 8000 cm-1.
-
-! The array KAO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels> ~100mb, temperatures, and binary
-! species parameters (see taumol.f for definition). The first
-! index in the array, JS, runs from 1 to 9, and corresponds to
-! different values of the binary species parameter. For instance,
-! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
-! JS = 3 corresponds to the parameter value 2/8, etc. The second index
-! in the array, JT, which runs from 1 to 5, corresponds to different
-! temperatures. More specifically, JT = 3 means that the data are for
-! the reference temperature TREF for this pressure level, JT = 2 refers
-! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
-! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
-! to the JPth reference pressure level (see taumol.f for these levels
-! in mb). The fourth index, IG, goes from 1 to 16, and indicates
-! which g-interval the absorption coefficients are for.
-
-! The array KBO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels < ~100mb and temperatures. The first
-! index in the array, JT, which runs from 1 to 5, corresponds to
-! different temperatures. More specifically, JT = 3 means that the
-! data are for the reference temperature TREF for this pressure
-! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
-! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
-! The second index, JP, runs from 13 to 59 and refers to the JPth
-! reference pressure level (see taumol.f for the value of these
-! pressure levels in mb). The third index, IG, goes from 1 to 16,
-! and tells us which g-interval the absorption coefficients are for.
-
-! The array FORREFO contains the coefficient of the water vapor
-! foreign-continuum (including the energy term). The first
-! index refers to reference temperature (296_rb,260_rb,224,260) and
-! pressure (970,475,219,3 mbar) levels. The second index
-! runs over the g-channel (1 to 16).
-
-! The array SELFREFO contains the coefficient of the water vapor
-! self-continuum (including the energy term). The first index
-! refers to temperature in 7.2 degree increments. For instance,
-! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
-! etc. The second index runs over the g-channel (1 to 16).
-
-#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
-#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
-#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
-
- IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
- rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
- DM_BCAST_REAL(rayl)
- DM_BCAST_REAL(strrat)
- DM_BCAST_INTEGER(layreffr)
- DM_BCAST_MACRO(kao)
- DM_BCAST_MACRO(kbo)
- DM_BCAST_MACRO(selfrefo)
- DM_BCAST_MACRO(forrefo)
- DM_BCAST_MACRO(sfluxrefo)
-
- RETURN
-9010 CONTINUE
- WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
- CALL wrf_error_fatal(errmess)
-
- end subroutine sw_kgb22
-
-! **************************************************************************
- subroutine sw_kgb23(rrtmg_unit)
-! **************************************************************************
-
- use rrsw_kg23, only : kao, selfrefo, forrefo, sfluxrefo, &
- raylo, givfac, layreffr
-
- implicit none
- save
-
-! Input
- integer, intent(in) :: rrtmg_unit
-
-! Local
- character*80 errmess
- logical, external :: wrf_dm_on_monitor
-
-! Array sfluxrefo contains the Kurucz solar source function for this band.
-
-! Array raylo contains the Rayleigh extinction coefficient at all v for this band
-
-! Array givfac is the average Giver et al. correction factor for this band.
-
-! The array KAO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels> ~100mb, temperatures, and binary
-! species parameters (see taumol.f for definition). The first
-! index in the array, JS, runs from 1 to 9, and corresponds to
-! different values of the binary species parameter. For instance,
-! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
-! JS = 3 corresponds to the parameter value 2/8, etc. The second index
-! in the array, JT, which runs from 1 to 5, corresponds to different
-! temperatures. More specifically, JT = 3 means that the data are for
-! the reference temperature TREF for this pressure level, JT = 2 refers
-! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
-! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
-! to the JPth reference pressure level (see taumol.f for these levels
-! in mb). The fourth index, IG, goes from 1 to 16, and indicates
-! which g-interval the absorption coefficients are for.
-
-! The array FORREFO contains the coefficient of the water vapor
-! foreign-continuum (including the energy term). The first
-! index refers to reference temperature (296,260,224,260) and
-! pressure (970,475,219,3 mbar) levels. The second index
-! runs over the g-channel (1 to 16).
-
-! The array SELFREFO contains the coefficient of the water vapor
-! self-continuum (including the energy term). The first index
-! refers to temperature in 7.2 degree increments. For instance,
-! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
-! etc. The second index runs over the g-channel (1 to 16).
-
-#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
-#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
-#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
-
- IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
- raylo, givfac, layreffr, kao, selfrefo, forrefo, sfluxrefo
- DM_BCAST_MACRO(raylo)
- DM_BCAST_REAL(givfac)
- DM_BCAST_INTEGER(layreffr)
- DM_BCAST_MACRO(kao)
- DM_BCAST_MACRO(selfrefo)
- DM_BCAST_MACRO(forrefo)
- DM_BCAST_MACRO(sfluxrefo)
-
- RETURN
-9010 CONTINUE
- WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
- CALL wrf_error_fatal(errmess)
-
- end subroutine sw_kgb23
-
-! **************************************************************************
- subroutine sw_kgb24(rrtmg_unit)
-! **************************************************************************
-
- use rrsw_kg24, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
- raylao, raylbo, abso3ao, abso3bo, strrat, layreffr
-
- implicit none
- save
-
-! Input
- integer, intent(in) :: rrtmg_unit
-
-! Local
- character*80 errmess
- logical, external :: wrf_dm_on_monitor
-
-! Array sfluxrefo contains the Kurucz solar source function for this band.
-
-! Arrays raylao and raylbo contain the Rayleigh extinction coefficient at
-! all v for this band for the upper and lower atmosphere.
-
-! Arrays abso3ao and abso3bo contain the ozone absorption coefficient at
-! all v for this band for the upper and lower atmosphere.
-
-! The array KAO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels> ~100mb, temperatures, and binary
-! species parameters (see taumol.f for definition). The first
-! index in the array, JS, runs from 1 to 9, and corresponds to
-! different values of the binary species parameter. For instance,
-! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
-! JS = 3 corresponds to the parameter value 2/8, etc. The second index
-! in the array, JT, which runs from 1 to 5, corresponds to different
-! temperatures. More specifically, JT = 3 means that the data are for
-! the reference temperature TREF for this pressure level, JT = 2 refers
-! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
-! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
-! to the JPth reference pressure level (see taumol.f for these levels
-! in mb). The fourth index, IG, goes from 1 to 16, and indicates
-! which g-interval the absorption coefficients are for.
-
-! The array KBO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels < ~100mb and temperatures. The first
-! index in the array, JT, which runs from 1 to 5, corresponds to
-! different temperatures. More specifically, JT = 3 means that the
-! data are for the reference temperature TREF for this pressure
-! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
-! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
-! The second index, JP, runs from 13 to 59 and refers to the JPth
-! reference pressure level (see taumol.f for the value of these
-! pressure levels in mb). The third index, IG, goes from 1 to 16,
-! and tells us which g-interval the absorption coefficients are for.
-
-! The array FORREFO contains the coefficient of the water vapor
-! foreign-continuum (including the energy term). The first
-! index refers to reference temperature (296,260,224,260) and
-! pressure (970,475,219,3 mbar) levels. The second index
-! runs over the g-channel (1 to 16).
-
-! The array SELFREFO contains the coefficient of the water vapor
-! self-continuum (including the energy term). The first index
-! refers to temperature in 7.2 degree increments. For instance,
-! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
-! etc. The second index runs over the g-channel (1 to 16).
-
-#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
-#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
-#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
-
- IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
- raylao, raylbo, strrat, layreffr, abso3ao, abso3bo, kao, kbo, selfrefo, &
- forrefo, sfluxrefo
- DM_BCAST_MACRO(raylao)
- DM_BCAST_MACRO(raylbo)
- DM_BCAST_REAL(strrat)
- DM_BCAST_INTEGER(layreffr)
- DM_BCAST_MACRO(abso3ao)
- DM_BCAST_MACRO(abso3bo)
- DM_BCAST_MACRO(kao)
- DM_BCAST_MACRO(kbo)
- DM_BCAST_MACRO(selfrefo)
- DM_BCAST_MACRO(forrefo)
- DM_BCAST_MACRO(sfluxrefo)
-
- RETURN
-9010 CONTINUE
- WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
- CALL wrf_error_fatal(errmess)
-
- end subroutine sw_kgb24
-
-! **************************************************************************
- subroutine sw_kgb25(rrtmg_unit)
-! **************************************************************************
-
- use rrsw_kg25, only : kao, sfluxrefo, &
- raylo, abso3ao, abso3bo, layreffr
-
- implicit none
- save
-
-! Input
- integer, intent(in) :: rrtmg_unit
-
-! Local
- character*80 errmess
- logical, external :: wrf_dm_on_monitor
-
-! Array sfluxrefo contains the Kurucz solar source function for this band.
-
-! Array raylo contains the Rayleigh extinction coefficient at all v = 2925 cm-1.
-
-! Arrays abso3ao and abso3bo contain the ozone absorption coefficient at
-! all v for this band for the upper and lower atmosphere.
-
-! The array KAO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels> ~100mb, temperatures, and binary
-! species parameters (see taumol.f for definition). The first
-! index in the array, JS, runs from 1 to 9, and corresponds to
-! different values of the binary species parameter. For instance,
-! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
-! JS = 3 corresponds to the parameter value 2/8, etc. The second index
-! in the array, JT, which runs from 1 to 5, corresponds to different
-! temperatures. More specifically, JT = 3 means that the data are for
-! the reference temperature TREF for this pressure level, JT = 2 refers
-! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
-! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
-! to the JPth reference pressure level (see taumol.f for these levels
-! in mb). The fourth index, IG, goes from 1 to 16, and indicates
-! which g-interval the absorption coefficients are for.
-
-#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
-#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
-
- IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
- raylo, layreffr, abso3ao, abso3bo, kao, sfluxrefo
- DM_BCAST_MACRO(raylo)
- DM_BCAST_INTEGER(layreffr)
- DM_BCAST_MACRO(abso3ao)
- DM_BCAST_MACRO(abso3bo)
- DM_BCAST_MACRO(kao)
- DM_BCAST_MACRO(sfluxrefo)
-
- RETURN
-9010 CONTINUE
- WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
- CALL wrf_error_fatal(errmess)
-
- end subroutine sw_kgb25
-
-! **************************************************************************
- subroutine sw_kgb26(rrtmg_unit)
-! **************************************************************************
-
- use rrsw_kg26, only : sfluxrefo, raylo
-
- implicit none
- save
-
-! Input
- integer, intent(in) :: rrtmg_unit
-
-! Local
- character*80 errmess
- logical, external :: wrf_dm_on_monitor
-
-! Array sfluxrefo contains the Kurucz solar source function for this band.
-
-! Array raylo contains the Rayleigh extinction coefficient at all v for this band.
-
-#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
-
- IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
- raylo, sfluxrefo
- DM_BCAST_MACRO(raylo)
- DM_BCAST_MACRO(sfluxrefo)
-
- RETURN
-9010 CONTINUE
- WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
- CALL wrf_error_fatal(errmess)
-
- end subroutine sw_kgb26
-
-! **************************************************************************
- subroutine sw_kgb27(rrtmg_unit)
-! **************************************************************************
-
- use rrsw_kg27, only : kao, kbo, sfluxrefo, raylo, &
- scalekur, layreffr
-
- implicit none
- save
-
-! Input
- integer, intent(in) :: rrtmg_unit
-
-! Local
- character*80 errmess
- logical, external :: wrf_dm_on_monitor
-
-! Array sfluxrefo contains the Kurucz solar source function for this band.
-! The values in array sfluxrefo were obtained using the "low resolution"
-! version of the Kurucz solar source function. For unknown reasons,
-! the total irradiance in this band differs from the corresponding
-! total in the "high-resolution" version of the Kurucz function.
-! Therefore, these values are scaled by the factor SCALEKUR.
-
-! Array raylo contains the Rayleigh extinction coefficient at all v = 2925 cm-1.
-
-! The array KAO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels> ~100mb, temperatures, and binary
-! species parameters (see taumol.f for definition). The first
-! index in the array, JS, runs from 1 to 9, and corresponds to
-! different values of the binary species parameter. For instance,
-! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
-! JS = 3 corresponds to the parameter value 2/8, etc. The second index
-! in the array, JT, which runs from 1 to 5, corresponds to different
-! temperatures. More specifically, JT = 3 means that the data are for
-! the reference temperature TREF for this pressure level, JT = 2 refers
-! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
-! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
-! to the JPth reference pressure level (see taumol.f for these levels
-! in mb). The fourth index, IG, goes from 1 to 16, and indicates
-! which g-interval the absorption coefficients are for.
-
-! The array KBO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels < ~100mb and temperatures. The first
-! index in the array, JT, which runs from 1 to 5, corresponds to
-! different temperatures. More specifically, JT = 3 means that the
-! data are for the reference temperature TREF for this pressure
-! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
-! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
-! The second index, JP, runs from 13 to 59 and refers to the JPth
-! reference pressure level (see taumol.f for the value of these
-! pressure levels in mb). The third index, IG, goes from 1 to 16,
-! and tells us which g-interval the absorption coefficients are for.
-
-#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
-#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
-#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
-
- IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
- raylo, scalekur, layreffr, kao, kbo, sfluxrefo
- DM_BCAST_MACRO(raylo)
- DM_BCAST_REAL(scalekur)
- DM_BCAST_INTEGER(layreffr)
- DM_BCAST_MACRO(kao)
- DM_BCAST_MACRO(kbo)
- DM_BCAST_MACRO(sfluxrefo)
-
- RETURN
-9010 CONTINUE
- WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
- CALL wrf_error_fatal(errmess)
-
- end subroutine sw_kgb27
-
-! **************************************************************************
- subroutine sw_kgb28(rrtmg_unit)
-! **************************************************************************
-
- use rrsw_kg28, only : kao, kbo, sfluxrefo, &
- rayl, strrat, layreffr
-
- implicit none
- save
-
-! Input
- integer, intent(in) :: rrtmg_unit
-
-! Local
- character*80 errmess
- logical, external :: wrf_dm_on_monitor
-
-! Array sfluxrefo contains the Kurucz solar source function for this band.
-
-! Array raylo contains the Rayleigh extinction coefficient at all v = ???? cm-1.
-
-! The array KAO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels> ~100mb, temperatures, and binary
-! species parameters (see taumol.f for definition). The first
-! index in the array, JS, runs from 1 to 9, and corresponds to
-! different values of the binary species parameter. For instance,
-! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
-! JS = 3 corresponds to the parameter value 2/8, etc. The second index
-! in the array, JT, which runs from 1 to 5, corresponds to different
-! temperatures. More specifically, JT = 3 means that the data are for
-! the reference temperature TREF for this pressure level, JT = 2 refers
-! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
-! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
-! to the JPth reference pressure level (see taumol.f for these levels
-! in mb). The fourth index, IG, goes from 1 to 16, and indicates
-! which g-interval the absorption coefficients are for.
-
-! The array KBO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels < ~100mb and temperatures. The first
-! index in the array, JT, which runs from 1 to 5, corresponds to
-! different temperatures. More specifically, JT = 3 means that the
-! data are for the reference temperature TREF for this pressure
-! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
-! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
-! The second index, JP, runs from 13 to 59 and refers to the JPth
-! reference pressure level (see taumol.f for the value of these
-! pressure levels in mb). The third index, IG, goes from 1 to 16,
-! and tells us which g-interval the absorption coefficients are for.
-
-#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
-#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
-#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
-
- IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
- rayl, strrat, layreffr, kao, kbo, sfluxrefo
- DM_BCAST_REAL(rayl)
- DM_BCAST_REAL(strrat)
- DM_BCAST_INTEGER(layreffr)
- DM_BCAST_MACRO(kao)
- DM_BCAST_MACRO(kbo)
- DM_BCAST_MACRO(sfluxrefo)
-
- RETURN
-9010 CONTINUE
- WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
- CALL wrf_error_fatal(errmess)
-
- end subroutine sw_kgb28
-
-! **************************************************************************
- subroutine sw_kgb29(rrtmg_unit)
-! **************************************************************************
-
- use rrsw_kg29, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
- absh2oo, absco2o, rayl, layreffr
-
- implicit none
- save
-
-! Input
- integer, intent(in) :: rrtmg_unit
-
-! Local
- character*80 errmess
- logical, external :: wrf_dm_on_monitor
-
-! Array sfluxrefo contains the Kurucz solar source function for this band.
-
-! Array rayl contains the Rayleigh extinction coefficient at all v = 2200 cm-1.
-
-! Array absh2oo contains the water vapor absorption coefficient for this band.
-
-! Array absco2o contains the carbon dioxide absorption coefficient for this band.
-
-! The array KAO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels> ~100mb, temperatures, and binary
-! species parameters (see taumol.f for definition). The first
-! index in the array, JS, runs from 1 to 9, and corresponds to
-! different values of the binary species parameter. For instance,
-! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
-! JS = 3 corresponds to the parameter value 2/8, etc. The second index
-! in the array, JT, which runs from 1 to 5, corresponds to different
-! temperatures. More specifically, JT = 3 means that the data are for
-! the reference temperature TREF for this pressure level, JT = 2 refers
-! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
-! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
-! to the JPth reference pressure level (see taumol.f for these levels
-! in mb). The fourth index, IG, goes from 1 to 16, and indicates
-! which g-interval the absorption coefficients are for.
-
-! The array KBO contains absorption coefs at the 16 chosen g-values
-! for a range of pressure levels < ~100mb and temperatures. The first
-! index in the array, JT, which runs from 1 to 5, corresponds to
-! different temperatures. More specifically, JT = 3 means that the
-! data are for the reference temperature TREF for this pressure
-! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
-! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
-! The second index, JP, runs from 13 to 59 and refers to the JPth
-! reference pressure level (see taumol.f for the value of these
-! pressure levels in mb). The third index, IG, goes from 1 to 16,
-! and tells us which g-interval the absorption coefficients are for.
-
-! The array FORREFO contains the coefficient of the water vapor
-! foreign-continuum (including the energy term). The first
-! index refers to reference temperature (296,260,224,260) and
-! pressure (970,475,219,3 mbar) levels. The second index
-! runs over the g-channel (1 to 16).
-
-! The array SELFREFO contains the coefficient of the water vapor
-! self-continuum (including the energy term). The first index
-! refers to temperature in 7.2 degree increments. For instance,
-! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
-! etc. The second index runs over the g-channel (1 to 16).
-
-#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
-#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
-#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
-
- IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
- rayl, layreffr, absh2oo, absco2o, kao, kbo, selfrefo, forrefo, sfluxrefo
- DM_BCAST_REAL(rayl)
- DM_BCAST_INTEGER(layreffr)
- DM_BCAST_MACRO(absh2oo)
- DM_BCAST_MACRO(absco2o)
- DM_BCAST_MACRO(kao)
- DM_BCAST_MACRO(kbo)
- DM_BCAST_MACRO(selfrefo)
- DM_BCAST_MACRO(forrefo)
- DM_BCAST_MACRO(sfluxrefo)
-
- RETURN
-9010 CONTINUE
- WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
- CALL wrf_error_fatal(errmess)
-
- end subroutine sw_kgb29
-
-!------------------------------------------------------------------
-
-END MODULE module_ra_rrtmg_sw
-!***********************************************************************
diff --git a/UTIL/wrfcmaq_twoway_coupler/phys/module_radiation_driver.F b/UTIL/wrfcmaq_twoway_coupler/phys/module_radiation_driver.F
deleted file mode 100644
index a8fabce64b..0000000000
--- a/UTIL/wrfcmaq_twoway_coupler/phys/module_radiation_driver.F
+++ /dev/null
@@ -1,5547 +0,0 @@
-
-!WRF:MEDIATION_LAYER:PHYSICS
-!
-MODULE module_radiation_driver
-CONTAINS
-!BOP
-! !IROUTINE: radiation_driver - interface to radiation physics options
-
-! !INTERFACE:
- SUBROUTINE radiation_driver ( &
- ACFRCV ,ACFRST ,ALBEDO &
- ,CFRACH ,CFRACL ,CFRACM &
- ,CUPPT ,CZMEAN ,DT &
- ,DZ8W ,EMISS ,GLW &
- ,GMT ,GSW ,HBOT &
- ,HTOP ,HBOTR ,HTOPR &
- ,ICLOUD &
- ,cldovrlp &
- ,ITIMESTEP,JULDAY, JULIAN &
- ,JULYR ,LW_PHYSICS &
- ,NCFRCV ,NCFRST ,NPHS &
- ,O3INPUT, O3RAD &
- ,AER_OPT, aerod &
- ,swint_opt &
- ,solar_opt &
- ,P8W ,P ,PI &
- ,p_top &
- ,RADT ,RA_CALL_OFFSET &
- ,RHO ,RLWTOA &
- ,RSWTOA ,RTHRATEN &
- ,RTHRATENLW ,RTHRATENSW &
- ,RTHRATENLWC ,RTHRATENSWC &
- ,SNOW ,STEPRA ,SWDOWN &
- ,SWDOWNC ,SW_PHYSICS &
- ,SW_ECLIPSE &
- ,T8W ,T ,TAUCLDC &
- ,TAUCLDI ,TSK ,VEGFRA &
- ,WARM_RAIN ,XICE ,XLAND &
- ,XLAT ,XLONG ,YR &
-!Optional solar variables
- ,DECLINX ,SOLCONX ,COSZEN ,HRANG &
- , CEN_LAT &
- ,Z &
- ,ALEVSIZ, no_src_types &
- ,LEVSIZ, N_OZMIXM &
- ,N_AEROSOLC &
- ,PAERLEV ,ID &
- ,CAM_ABS_DIM1, CAM_ABS_DIM2 &
- ,CAM_ABS_FREQ_S &
- ,XTIME &
- ,CURR_SECS, ADAPT_STEP_FLAG &
- ,SWDOWN2, SWDDNI2, SWDDIF2, SWDDIR2 &
- ,SWDOWNC2, SWDDNIC2 &
- !BSINGH - For WRFCuP scheme (optional args)
- ,cu_physics,shallowcu_forced_ra &
- ,cubot,cutop,cldfra_cup &
- ,shall &
- !BSINGH - ENDS
- ! indexes
- ,IDS,IDE, JDS,JDE, KDS,KDE &
- ,IMS,IME, JMS,JME, KMS,KME &
- ,i_start,i_end &
- ,j_start,j_end &
- ,kts, kte &
- ,num_tiles &
- ! Optional
- , TLWDN, TLWUP &
- , SLWDN, SLWUP &
- , TSWDN, TSWUP &
- , SSWDN, SSWUP &
- , RE_CLOUD_GSFC &
- , RE_RAIN_GSFC &
- , RE_ICE_GSFC &
- , RE_SNOW_GSFC &
- , RE_GRAUPEL_GSFC &
- , RE_HAIL_GSFC &
- , COD2D_OUT &
- , CTOP2D_OUT &
- , CLDFRA,CLDFRA_MP_ALL,CLDT,ZNU &
- , CCLDFRA, QCCONV, QICONV &
- , bmj_rad_feedback &
-#if (EM_CORE == 1)
- , lradius,iradius &
-#endif
- , cldfra_dp, cldfra_sh &
- , re_cloud, re_ice, re_snow &
- , has_reqc, has_reqi, has_reqs &
- , PB &
- , F_ICE_PHY,F_RAIN_PHY &
- , F_QNC &
- , QNC_CURR &
- , QV, F_QV &
- , QC, F_QC &
- , QR, F_QR &
- , QI, F_QI &
- , QI2, F_QI2 &
- , QI3, F_QI3 &
- , QS, F_QS &
- , QG, F_QG &
- , QH, F_QH &
- , QNDROP, F_QNDROP &
- ,QNIFA,F_QNIFA &
- ,QNWFA,F_QNWFA &
- ,qc_tot, qi_tot &
- ,ACSWUPT ,ACSWUPTC &
- ,ACSWDNT ,ACSWDNTC &
- ,ACSWUPB ,ACSWUPBC &
- ,ACSWDNB ,ACSWDNBC &
- ,ACLWUPT ,ACLWUPTC &
- ,ACLWDNT ,ACLWDNTC &
- ,ACLWUPB ,ACLWUPBC &
- ,ACLWDNB ,ACLWDNBC &
- ,SWUPT ,SWUPTC, SWUPTCLN &
- ,SWDNT ,SWDNTC, SWDNTCLN &
- ,SWUPB ,SWUPBC, SWUPBCLN &
- ,SWDNB ,SWDNBC, SWDNBCLN &
- ,LWUPT ,LWUPTC, LWUPTCLN &
- ,LWDNT ,LWDNTC, LWDNTCLN &
- ,LWUPB ,LWUPBC, LWUPBCLN &
- ,LWDNB ,LWDNBC, LWDNBCLN &
- ,LWCF &
- ,SWCF &
- ,OLR &
- ,aerodm, PINA, aodtot &
- ,OZMIXM, PIN &
- ,M_PS_1, M_PS_2, AEROSOLC_1 &
- ,AEROSOLC_2, M_HYBI0 &
- ,ABSTOT, ABSNXT, EMSTOT &
- ,ICLOUD_CU &
- ,CALC_CLEAN_ATM_DIAG &
- ,AER_RA_FEEDBACK &
- ,QC_CU , QI_CU &
- ,icloud_bl,qc_bl,qi_bl,cldfra_bl &
- ,PM2_5_DRY, PM2_5_WATER &
- ,PM2_5_DRY_EC &
- ,TAUAER300, TAUAER400 &
- ,TAUAER600, TAUAER999 &
- ,GAER300, GAER400, GAER600, GAER999 &
- ,WAER300, WAER400, WAER600, WAER999 &
- ,TAUAERlw1, TAUAERlw2 &
- ,TAUAERlw3, TAUAERlw4 &
- ,TAUAERlw5, TAUAERlw6 &
- ,TAUAERlw7, TAUAERlw8 &
- ,TAUAERlw9, TAUAERlw10 &
- ,TAUAERlw11, TAUAERlw12 &
- ,TAUAERlw13, TAUAERlw14 &
- ,TAUAERlw15, TAUAERlw16 &
- ,progn &
- ,slope_rad,topo_shading &
- ,shadowmask,ht,dx,dy,dx2d,area2d &
- ,dxkm &
- ,diffuse_frac &
- ,SWUPFLX,SWUPFLXC,SWDNFLX,SWDNFLXC &
- ,LWUPFLX,LWUPFLXC,LWDNFLX,LWDNFLXC &
- ,radtacttime &
- ,ALSWVISDIR, ALSWVISDIF, ALSWNIRDIR, ALSWNIRDIF &
- ,SWVISDIR, SWVISDIF, SWNIRDIR, SWNIRDIF &
- ,SF_SURFACE_PHYSICS, IS_CAMMGMP_USED &
- ,EXPLICIT_CONVECTION &
- ,swddir,swddni,swddif &
- ,swddirc,swddnic &
- ,swdown_ref,swddir_ref,coszen_ref,Gx,gg,Bx,bb &
- ,aer_type &
- ,aer_aod550_opt, aer_aod550_val &
- ,aer_angexp_opt, aer_angexp_val &
- ,aer_ssa_opt, aer_ssa_val &
- ,aer_asy_opt, aer_asy_val &
- ,aod5502d, angexp2d, aerssa2d, aerasy2d &
- ,aod5503d &
- ,cw_rad, shcu_physics &
- ,obscur,mask,elat_track,elon_track &
- ,taod5502d, taod5503d &
- ,mp_physics &
- ,EFCG,EFCS,EFIG,EFIS,EFSG,aercu_opt &
- ,EFSS,QS_CU &
-#if (WRF_CHEM == 1)
- ,chem &
- ,aod_out &
- , AOD2D_OUT &
- , ATOP2D_OUT &
- ,chem_opt &
- ,gsfcrad_gocart_coupling &
-#endif
- ,feedback_is_ready & ! WRF-CMAQ twoway coupled model
- ,mass_ws_i & ! WRF-CMAQ twoway coupled model
- ,mass_ws_j & ! WRF-CMAQ twoway coupled model
- ,mass_ws_k & ! WRF-CMAQ twoway coupled model
- ,mass_in_i & ! WRF-CMAQ twoway coupled model
- ,mass_in_j & ! WRF-CMAQ twoway coupled model
- ,mass_in_k & ! WRF-CMAQ twoway coupled model
- ,mass_ec_i & ! WRF-CMAQ twoway coupled model
- ,mass_ec_j & ! WRF-CMAQ twoway coupled model
- ,mass_ec_k & ! WRF-CMAQ twoway coupled model
- ,mass_ss_i & ! WRF-CMAQ twoway coupled model
- ,mass_ss_j & ! WRF-CMAQ twoway coupled model
- ,mass_ss_k & ! WRF-CMAQ twoway coupled model
- ,mass_h2o_i & ! WRF-CMAQ twoway coupled model
- ,mass_h2o_j & ! WRF-CMAQ twoway coupled model
- ,mass_h2o_k & ! WRF-CMAQ twoway coupled model
- ,dgn_i & ! WRF-CMAQ twoway coupled model
- ,dgn_j & ! WRF-CMAQ twoway coupled model
- ,dgn_k & ! WRF-CMAQ twoway coupled model
- ,sig_i & ! WRF-CMAQ twoway coupled model
- ,sig_j & ! WRF-CMAQ twoway coupled model
- ,sig_k & ! WRF-CMAQ twoway coupled model
- ,sw_gtauxar_01 & ! WRF-CMAQ twoway coupled model
- ,sw_gtauxar_02 & ! WRF-CMAQ twoway coupled model
- ,sw_gtauxar_03 & ! WRF-CMAQ twoway coupled model
- ,sw_gtauxar_04 & ! WRF-CMAQ twoway coupled model
- ,sw_gtauxar_05 & ! WRF-CMAQ twoway coupled model
- ,sw_ttauxar_01 & ! WRF-CMAQ twoway coupled model
- ,sw_ttauxar_02 & ! WRF-CMAQ twoway coupled model
- ,sw_ttauxar_03 & ! WRF-CMAQ twoway coupled model
- ,sw_ttauxar_04 & ! WRF-CMAQ twoway coupled model
- ,sw_ttauxar_05 & ! WRF-CMAQ twoway coupled model
- ,sw_asy_fac_01 & ! WRF-CMAQ twoway coupled model
- ,sw_asy_fac_02 & ! WRF-CMAQ twoway coupled model
- ,sw_asy_fac_03 & ! WRF-CMAQ twoway coupled model
- ,sw_asy_fac_04 & ! WRF-CMAQ twoway coupled model
- ,sw_asy_fac_05 & ! WRF-CMAQ twoway coupled model
- ,sw_ssa_01 & ! WRF-CMAQ twoway coupled model
- ,sw_ssa_02 & ! WRF-CMAQ twoway coupled model
- ,sw_ssa_03 & ! WRF-CMAQ twoway coupled model
- ,sw_ssa_04 & ! WRF-CMAQ twoway coupled model
- ,sw_ssa_05 & ! WRF-CMAQ twoway coupled model
- ,ozone & ! WRF-CMAQ twoway coupled model
- ,sw_zbbcddir & ! WRF-CMAQ twoway coupled model
- ,sw_dirdflux & ! WRF-CMAQ twoway coupled model
- ,sw_difdflux & ! WRF-CMAQ twoway coupled model
- )
-
-!-------------------------------------------------------------------------
-
-! !USES:
- USE module_state_description, ONLY : RRTMSCHEME, GFDLLWSCHEME &
- ,RRTMG_LWSCHEME, RRTMG_SWSCHEME &
-#if( BUILD_RRTMG_FAST == 1)
- ,RRTMG_LWSCHEME_FAST, RRTMG_SWSCHEME_FAST &
-#endif
-#if( BUILD_RRTMK == 1)
- ,RRTMK_LWSCHEME, RRTMK_SWSCHEME &
-#endif
- ,SWRADSCHEME, GSFCSWSCHEME &
- ,GFDLSWSCHEME, CAMLWSCHEME, CAMSWSCHEME &
- ,HELDSUAREZ &
-#if ( HWRF == 1 )
- ,HWRFSWSCHEME, HWRFLWSCHEME &
-#endif
- ,goddardswscheme & !NUWRF
- ,goddardlwscheme & !NUWRF
-# if (EM_CORE == 1)
- ,CAMMGMPSCHEME &
-#if (WRF_CHEM == 1)
-
- ,num_chem & !NUWRF
- ,p_bc1, p_bc2, p_oc1, p_oc2 & !NUWRF
- ,p_dust_1, p_dust_2, p_dust_3 & !NUWRF
- ,p_dust_4, p_dust_5 & !NUWRF
- ,p_sulf, p_seas_1, p_seas_2 & !NUWRF
- ,p_seas_3, p_seas_4 & !NUWRF
-#endif
-#endif
- ,KFCUPSCHEME, BMJSCHEME & !BSINGH - Added KFCUPSCHEME for WRFCuP scheme
- ,FLGLWSCHEME, FLGSWSCHEME &
- ,ECLIPSESCHEME
-
- USE module_model_constants
-#ifndef HWRF
- USE module_wrf_error , ONLY : wrf_err_message
-#endif
- USE module_state_description, ONLY : nuwrf4icescheme
-
-! *** add new modules of schemes here
-
-#if ( WRF_CMAQ == 1)
- USE module_twoway_ra_rrtmg_sw
-#endif
-
- USE module_ra_sw , ONLY : swrad
- USE module_ra_gsfcsw , ONLY : gsfcswrad
- USE module_ra_rrtm , ONLY : rrtmlwrad
- USE module_ra_rrtmg_lw , ONLY : rrtmg_lwrad, rrtmg_lwinit
- USE module_ra_rrtmg_sw , ONLY : rrtmg_swrad
-#if( BUILD_RRTMG_FAST == 1)
- USE module_ra_rrtmg_lwf , ONLY : rrtmg_lwrad_fast
- USE module_ra_rrtmg_swf , ONLY : rrtmg_swrad_fast
-#endif
-#if( BUILD_RRTMK == 1)
- USE module_ra_rrtmg_swk , ONLY : rad_rrtmg_driver
-#endif
- USE module_ra_cam , ONLY : camrad
- USE module_ra_gfdleta , ONLY : etara
-#if ( HWRF == 1 )
- USE module_ra_hwrf
-#endif
- USE module_ra_hs , ONLY : hsrad
-
- USE module_ra_goddard , ONLY : goddardrad
- USE module_ra_flg , ONLY : RAD_FLG
-
- USE module_ra_aerosol , ONLY : calc_aerosol_goddard_sw, &
- calc_aerosol_rrtmg_sw
- USE module_ra_farms , ONLY : farms_driver
-! amontornes-bcodina 2015/09 solar eclipses
- USE module_ra_eclipse , ONLY : solar_eclipse
-
- ! This driver calls subroutines for the radiation parameterizations.
- !
- ! short wave radiation choices:
- ! 1. swrad (19??)
- ! 4. rrtmg_sw - Added November 2008, MJIacono, AER, Inc.
- !
- ! long wave radiation choices:
- ! 1. rrtmlwrad
- ! 4. rrtmg_lw - Added November 2008, MJIacono, AER, Inc.
- !
-!----------------------------------------------------------------------
- IMPLICIT NONE
-!
-!
-! Radiation_driver is the WRF mediation layer routine that provides the interface to
-! to radiation physics packages in the WRF model layer. The radiation
-! physics packages to call are chosen by setting the namelist variable
-! (Rconfig entry in Registry) to the integer value assigned to the
-! particular package (package entry in Registry). For example, if the
-! namelist variable ra_lw_physics is set to 1, this corresponds to the
-! Registry Package entry for swradscheme. Note that the Package
-! names in the Registry are defined constants (frame/module_state_description.F)
-! in the CASE statements in this routine.
-!
-! Among the arguments is moist, a four-dimensional scalar array storing
-! a variable number of moisture tracers, depending on the physics
-! configuration for the WRF run, as determined in the namelist. The
-! highest numbered index of active moisture tracers the integer argument
-! n_moist (note: the number of tracers at run time is the quantity
-! n_moist - PARAM_FIRST_SCALAR + 1 , not n_moist. Individual tracers
-! may be indexed from moist by the Registry name of the tracer prepended
-! with P_; for example P_QC is the index of cloud water. An index
-! represents a valid, active field only if the index is greater than
-! or equal to PARAM_FIRST_SCALAR. PARAM_FIRST_SCALAR and the individual
-! indices for each tracer is defined in module_state_description and
-! set in set_scalar_indices_from_config defined in frame/module_configure.F.
-!
-! Physics drivers in WRF 2.0 and higher, originally model-layer
-! routines, have been promoted to mediation layer routines and they
-! contain OpenMP threaded loops over tiles. Thus, physics drivers
-! are called from single-threaded regions in the solver. The physics
-! routines that are called from the physics drivers are model-layer
-! routines and fully tile-callable and thread-safe.
-!
-!
-!======================================================================
-! Grid structure in physics part of WRF
-!----------------------------------------------------------------------
-! The horizontal velocities used in the physics are unstaggered
-! relative to temperature/moisture variables. All predicted
-! variables are carried at half levels except w, which is at full
-! levels. Some arrays with names (*8w) are at w (full) levels.
-!
-!----------------------------------------------------------------------
-! In WRF, kms (smallest number) is the bottom level and kme (largest
-! number) is the top level. In your scheme, if 1 is at the top level,
-! then you have to reverse the order in the k direction.
-!
-! kme - half level (no data at this level)
-! kme ----- full level
-! kme-1 - half level
-! kme-1 ----- full level
-! .
-! .
-! .
-! kms+2 - half level
-! kms+2 ----- full level
-! kms+1 - half level
-! kms+1 ----- full level
-! kms - half level
-! kms ----- full level
-!
-!======================================================================
-! Grid structure in physics part of WRF
-!
-!-------------------------------------
-! The horizontal velocities used in the physics are unstaggered
-! relative to temperature/moisture variables. All predicted
-! variables are carried at half levels except w, which is at full
-! levels. Some arrays with names (*8w) are at w (full) levels.
-!
-!==================================================================
-! Definitions
-!-----------
-! Theta potential temperature (K)
-! Qv water vapor mixing ratio (kg/kg)
-! Qc cloud water mixing ratio (kg/kg)
-! Qr rain water mixing ratio (kg/kg)
-! Qi cloud ice mixing ratio (kg/kg)
-! Qs snow mixing ratio (kg/kg)
-! QCCONV convective cloud mixing ratio (kg/kg)
-! QICONV convective ice mixing ratio (kg/kg)
-!-----------------------------------------------------------------
-!-- PM2_5_DRY Dry PM2.5 aerosol mass for all species (ug m^-3)
-!-- PM2_5_WATER PM2.5 water mass (ug m^-3)
-!-- PM2_5_DRY_EC Dry PM2.5 elemental carbon aersol mass (ug m^-3)
-!-- RTHRATEN Theta tendency
-! due to radiation (K/s)
-!-- RTHRATENLW Theta tendency
-! due to long wave radiation (K/s)
-!-- RTHRATENLWC Theta tendency
-! due to clear-sky long wave radiation (K/s)
-!-- RTHRATENSW Theta temperature tendency
-! due to short wave radiation (K/s)
-!-- RTHRATENSWC Theta tendency
-! due to clear-sky short wave radiation (K/s)
-!-- dt time step (s)
-!-- itimestep number of time steps
-!-- GLW downward long wave flux at ground surface (W/m^2)
-!-- GSW net short wave flux at ground surface (W/m^2)
-!-- SWDOWN downward short wave flux at ground surface (W/m^2)
-!-- SWDOWNC clear-sky downward short wave flux at ground surface (W/m^2; optional; for AQ)
-!-- RLWTOA upward long wave at top of atmosphere (w/m2)
-!-- RSWTOA upward short wave at top of atmosphere (w/m2)
-!-- XLAT latitude, south is negative (degree)
-!-- XLONG longitude, west is negative (degree)
-!-- ALBEDO albedo (between 0 and 1)
-!-- CLDFRA cloud fraction (between 0 and 1)
-!-- CLDFRA_DP cloud fraction from deep cloud in a cumulus scheme
-!-- CLDFRA_SH cloud fraction from shallow cloud in a cumulus scheme
-!-- CLDFRA_MP_ALL cloud fraction from CAMMGMP microphysics scheme
-!-- CCLDFRA convective cloud fraction (between 0 and 1)
-!-- EMISS surface emissivity (between 0 and 1)
-!-- rho_phy density (kg/m^3)
-!-- rr dry air density (kg/m^3)
-!-- moist moisture array (4D - last index is species) (kg/kg)
-!-- n_moist number of moisture species
-!-- qndrop Cloud droplet number (#/kg)
-!-- p8w pressure at full levels (Pa)
-!-- p_phy pressure (Pa)
-!-- Pb base-state pressure (Pa)
-!-- pi_phy exner function (dimensionless)
-!-- dz8w dz between full levels (m)
-!-- t_phy temperature (K)
-!-- t8w temperature at full levels (K)
-!-- GMT Greenwich Mean Time Hour of model start (hour)
-!-- JULDAY the initial day (Julian day)
-!-- RADT time for calling radiation (min)
-!-- ra_call_offset -1 (old) means usually just before output, 0 after
-!-- DEGRAD conversion factor for
-! degrees to radians (pi/180.) (rad/deg)
-!-- DPD degrees per day for earth's
-! orbital position (deg/day)
-!-- R_d gas constant for dry air (J/kg/K)
-!-- CP heat capacity at constant pressure for dry air (J/kg/K)
-!-- G acceleration due to gravity (m/s^2)
-!-- rvovrd R_v divided by R_d (dimensionless)
-!-- XTIME time since simulation start (min)
-!-- DECLIN solar declination angle (rad)
-!-- SOLCON solar constant (W/m^2)
-!-- ids start index for i in domain
-!-- ide end index for i in domain
-!-- jds start index for j in domain
-!-- jde end index for j in domain
-!-- kds start index for k in domain
-!-- kde end index for k in domain
-!-- ims start index for i in memory
-!-- ime end index for i in memory
-!-- jms start index for j in memory
-!-- jme end index for j in memory
-!-- kms start index for k in memory
-!-- kme end index for k in memory
-!-- i_start start indices for i in tile
-!-- i_end end indices for i in tile
-!-- j_start start indices for j in tile
-!-- j_end end indices for j in tile
-!-- kts start index for k in tile
-!-- kte end index for k in tile
-!-- num_tiles number of tiles
-!
-!==================================================================
-!
- LOGICAL, OPTIONAL, INTENT(IN) :: explicit_convection
- LOGICAL,INTENT(IN) :: bmj_rad_feedback
-
- LOGICAL :: expl_conv
- INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- kts,kte, &
- num_tiles
-
- INTEGER, INTENT(IN) :: lw_physics, sw_physics, mp_physics, sw_eclipse
- INTEGER, INTENT(IN) :: o3input, aer_opt
- INTEGER, INTENT(IN) :: id
- integer, intent(in) :: swint_opt
- integer, intent(in), OPTIONAL :: solar_opt
- integer :: solar_opt_local
-
- INTEGER, DIMENSION(num_tiles), INTENT(IN) :: &
- i_start,i_end,j_start,j_end
-
- INTEGER, INTENT(IN ) :: STEPRA,ICLOUD,ra_call_offset
- INTEGER, INTENT(IN ) :: cldovrlp ! J. Henderson AER: cldovrlp namelist value
- INTEGER, INTENT(IN ) :: alevsiz, no_src_types
- INTEGER, INTENT(IN ) :: levsiz, n_ozmixm
- INTEGER, INTENT(IN ) :: paerlev, n_aerosolc, cam_abs_dim1, cam_abs_dim2
- REAL, INTENT(IN ) :: cam_abs_freq_s
-
- LOGICAL, INTENT(IN ) :: warm_rain
- INTEGER, INTENT(IN ) :: cu_physics !CuP, wig 5-Oct-2006 !BSINGH - For WRFCuP scheme
- !BSINGH - For WRFCuP scheme
- LOGICAL, OPTIONAL, INTENT(IN) :: shallowcu_forced_ra !CuP, wig
- !BSINGH -ENDS
- LOGICAL, INTENT(IN ) :: is_CAMMGMP_used !BSINGH:01/31/2013: Added for CAM5 RRTMG
-
- REAL, INTENT(IN ) :: RADT
-
- REAL, DIMENSION( ims:ime, jms:jme ), &
- INTENT(IN ) :: XLAND, &
- XICE, &
- TSK, &
- VEGFRA, &
- SNOW
- REAL, DIMENSION( ims:ime, levsiz, jms:jme, n_ozmixm ), OPTIONAL, &
- INTENT(IN ) :: OZMIXM
- REAL, DIMENSION( ims:ime, alevsiz, jms:jme, no_src_types, n_ozmixm-1 ), OPTIONAL, &
- INTENT(IN ) :: AERODM
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme, no_src_types ), OPTIONAL, &
- INTENT(INOUT) :: AEROD
- REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, &
- INTENT(INOUT) :: AODTOT
-
- REAL, DIMENSION( ims:ime, levsiz, jms:jme, n_ozmixm ) :: OZFLG
-
- REAL, DIMENSION(levsiz), OPTIONAL, INTENT(IN ) :: PIN
- REAL, DIMENSION(alevsiz), OPTIONAL, INTENT(IN ) :: PINA
-
- REAL, DIMENSION(ims:ime,jms:jme), OPTIONAL, INTENT(IN ) :: m_ps_1,m_ps_2
- REAL, DIMENSION( ims:ime, paerlev, jms:jme, n_aerosolc ), OPTIONAL, &
- INTENT(IN ) :: aerosolc_1, aerosolc_2
- REAL, DIMENSION(paerlev), OPTIONAL, &
- INTENT(IN ) :: m_hybi0
-
- REAL, DIMENSION( ims:ime, jms:jme ), &
- INTENT(INOUT) :: HTOP, &
- HBOT, &
- HTOPR, &
- HBOTR, &
- CUPPT
-
- !BSINGH - For WRFCuP scheme
- REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, &
- INTENT(INOUT) :: &
- cutop, & !CuP, wig 1-Oct-2006
- cubot, & !CuP, wig 1-Oct-2006
- shall !CuP, wig 4-Feb-2008
- !BSINGH -ENDS
-
-
- INTEGER, INTENT(IN ) :: julyr
-!
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
- INTENT(IN ) :: dz8w, &
- z, &
- p8w, &
- p, &
- pi, &
- t, &
- t8w, &
- rho
-
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
- OPTIONAL, &
- INTENT(IN ) :: cw_rad
- INTEGER, OPTIONAL, INTENT(IN) :: shcu_physics
-
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL, &
- INTENT(IN) :: EFCG, &
- EFCS, &
- EFIG, &
- EFIS, &
- EFSG, &
- EFSS
-
- !BSINGH - For WRFCuP scheme
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL, &
- INTENT(INOUT ) :: cldfra_cup !CuP, wig 1-Oct-2006
-
-
- !BSINGH -ENDS
-
-!
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , &
- INTENT(IN ) :: tauaer300,tauaer400,tauaer600,tauaer999, & ! jcb
- gaer300,gaer400,gaer600,gaer999, & ! jcb
- waer300,waer400,waer600,waer999
-
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
- INTENT(IN ) :: qc_cu, qi_cu
-
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , &
- INTENT(IN ) :: qc_bl, qi_bl, qs_cu
-
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , &
- INTENT(IN ) :: tauaerlw1,tauaerlw2,tauaerlw3,tauaerlw4, & ! czhao
- tauaerlw5,tauaerlw6,tauaerlw7,tauaerlw8, & ! czhao
- tauaerlw9,tauaerlw10,tauaerlw11,tauaerlw12, & ! czhao
- tauaerlw13,tauaerlw14,tauaerlw15,tauaerlw16
-
- INTEGER, INTENT(IN) :: icloud_cu
-
- INTEGER, INTENT(IN ), OPTIONAL :: icloud_bl
- INTEGER, INTENT(IN ), OPTIONAL :: aer_ra_feedback
- INTEGER, INTENT(IN ) :: calc_clean_atm_diag
-
-!jdfcz INTEGER, OPTIONAL, INTENT(IN ) :: progn,prescribe
- INTEGER, OPTIONAL, INTENT(IN ) :: progn
-!
-! variables for aerosols (only if running with chemistry)
-!
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , &
- INTENT(IN ) :: pm2_5_dry, &
- pm2_5_water, &
- pm2_5_dry_ec
-!
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
- INTENT(INOUT) :: RTHRATEN, &
- RTHRATENLW, &
- RTHRATENLWC,&
- RTHRATENSW, &
- RTHRATENSWC
-
-! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , &
-! INTENT(INOUT) :: SWUP, &
-! SWDN, &
-! SWUPCLEAR, &
-! SWDNCLEAR, &
-! LWUP, &
-! LWDN, &
-! LWUPCLEAR, &
-! LWDNCLEAR
-
- REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT) ::&
- ACSWUPT,ACSWUPTC,ACSWDNT,ACSWDNTC, &
- ACSWUPB,ACSWUPBC,ACSWDNB,ACSWDNBC, &
- ACLWUPT,ACLWUPTC,ACLWDNT,ACLWDNTC, &
- ACLWUPB,ACLWUPBC,ACLWDNB,ACLWDNBC
-
-! TOA and surface, upward and downward, total, clear (no cloud), and clean (no aerosol) fluxes
- REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT) ::&
- SWUPT, SWUPTC, SWUPTCLN, SWDNT, SWDNTC, SWDNTCLN,&
- SWUPB, SWUPBC, SWUPBCLN, SWDNB, SWDNBC, SWDNBCLN,&
- LWUPT, LWUPTC, LWUPTCLN, LWDNT, LWDNTC, LWDNTCLN,&
- LWUPB, LWUPBC, LWUPBCLN, LWDNB, LWDNBC, LWDNBCLN
-
-
-! Upward and downward, total and clear sky layer fluxes (W m-2)
- REAL, DIMENSION( ims:ime, kms:kme+2, jms:jme ), &
- OPTIONAL, INTENT(INOUT) :: &
- SWUPFLX,SWUPFLXC,SWDNFLX,SWDNFLXC, &
- LWUPFLX,LWUPFLXC,LWDNFLX,LWDNFLXC
-
- REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL , &
- INTENT(INOUT) :: SWCF, &
- LWCF, &
- OLR
-! ---- fds (06/2010) ssib alb components ------------
- REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL , &
- INTENT(IN ) :: ALSWVISDIR, &
- ALSWVISDIF, &
- ALSWNIRDIR, &
- ALSWNIRDIF
-! ---- fds (06/2010) ssib swr components ------------
- REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL , &
- INTENT(OUT ) :: SWVISDIR, &
- SWVISDIF, &
- SWNIRDIR, &
- SWNIRDIF
- INTEGER, OPTIONAL, INTENT(IN ) :: sf_surface_physics
-!
- REAL, DIMENSION( ims:ime, jms:jme ), &
- INTENT(IN ) :: XLAT, &
- XLONG, &
- ALBEDO, &
- EMISS
-!
- REAL, DIMENSION( ims:ime, jms:jme ), &
- INTENT(INOUT) :: GSW, &
- GLW
-
- REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: SWDOWN
- ! PAJ: FARMS coupling
- REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT), OPTIONAL :: SWDOWN2, SWDDNI2, SWDDIF2, SWDDIR2, SWDOWNC2, SWDDNIC2
-
-! ------------------------------------------------------------------------------ jararias 2013/08/10 -----------
- REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: swddir, & ! All-sky SW broadband surface direct irradiance
- swddni, & ! All-sky SW broadband surface direct normal irradiance
- swddif ! All-sky SW broadband surface diffuse irradiance
- REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: Gx,Bx,gg,bb, & ! For SW sza-interpolation
- swdown_ref, &
- swddir_ref, &
- coszen_ref
-! ------------------------------------------------------------------------------ jararias 2013/11 -----------
- INTEGER, INTENT(IN) :: aer_type, & ! rural, urban, maritime, ...
- aer_aod550_opt, & ! input option for AOD at 550 nm
- aer_angexp_opt, & ! input option for aerosol Angstrom exponent
- aer_ssa_opt, & ! input option for aerosol ssa
- aer_asy_opt, & ! input option for aerosol asy
- aercu_opt !
- REAL, INTENT(IN) :: aer_aod550_val, & ! AOD at 550 nm if aer_aod550_opt=1
- aer_angexp_val, & ! aerosol Angstrom exponent if aer_angexp_opt=1
- aer_ssa_val, & ! aerosol ssa if aer_ssa_opt=1
- aer_asy_val ! aerosol asy if aer_asy_opt=1
- REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, &
- INTENT(INOUT) :: aod5502d, & ! gridded AOD at 550 nm from auxinput
- angexp2d, & ! gridded aerosol Angstrom exponent from auxinput
- aerssa2d, & ! gridded aerosol ssa from auxinput
- aerasy2d ! gridded aerosol asy from auxinput
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL, &
- INTENT(OUT) :: aod5503d ! 3D AOD at 550 nm
-
- REAL, DIMENSION(ims:ime,kms:kme,jms:jme), OPTIONAL:: taod5503d ! Trude
- REAL, DIMENSION(ims:ime,jms:jme), OPTIONAL:: taod5502d ! Trude
-!
- REAL, INTENT(IN ) :: GMT,dt, &
- julian, xtime
- INTEGER, INTENT(IN ),OPTIONAL :: YR
-!
- INTEGER, INTENT(IN ) :: JULDAY, itimestep
- REAL, INTENT(IN ),OPTIONAL :: CURR_SECS
- LOGICAL, INTENT(IN ),OPTIONAL :: ADAPT_STEP_FLAG
-
- INTEGER,INTENT(IN) :: NPHS
- REAL, DIMENSION( ims:ime, jms:jme ),INTENT(OUT) :: &
- CFRACH, & !Added
- CFRACL, & !Added
- CFRACM, & !Added
- CZMEAN !Added
- REAL, DIMENSION( ims:ime, jms:jme ), &
- INTENT(INOUT) :: &
- RLWTOA, & !Added
- RSWTOA, & !Added
- ACFRST, & !Added
- ACFRCV !Added
-
- INTEGER,DIMENSION( ims:ime, jms:jme ),INTENT(INOUT) :: &
- NCFRST, & !Added
- NCFRCV !Added
-
-! NUWRF JJS 20101021 vvvvv
-! for inline Gocart coupling
-#if( WRF_CHEM == 1)
-
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem), &
- INTENT(IN) :: chem
- real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(out) :: aod_out !Aeorosol Optical Depth
-
- real, dimension( ims:ime, jms:jme ), OPTIONAL, INTENT(OUT) :: & !goddardrad
- aod2d_out ,& ! column aerosol optical depth
- atop2d_out ! aerosol top pressure [mb]
-
-
- integer :: i24h
- INTEGER, PARAMETER :: num_go = 14 ! number of the gocart aerosol species
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_go) :: aero
- REAL, PARAMETER :: frac(4)=(/ 0.01053,0.08421,0.25263,0.65263 /) !fraction for fine dust
- integer,intent(in) :: chem_opt ! EMK
- integer,intent(in) :: gsfcrad_gocart_coupling ! EMK
-
-#endif
-! NUWRF JJS 20101021 ^^^^^
-
-! JJS 20090623 vvvvv
-! Optional, only for Goddard LW and SW
- REAL, DIMENSION(IMS:IME, JMS:JME, 1:8) :: ERBE_out !extra output for SDSU
- REAL, DIMENSION(IMS:IME, JMS:JME), OPTIONAL, INTENT(INOUT) :: & !BSINGH(PNNL)- Lahey compiler forced this specification to be intent-inout
- TLWDN, TLWUP, &
- SLWDN, SLWUP, &
- TSWDN, TSWUP, &
- SSWDN, SSWUP ! for Goddard schemes
-! NUWRF JJS 20090623 ^^^^^
-
-! NUWRF JJS 20140225 vvvvv
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL ,&
- INTENT(INOUT) :: re_cloud_gsfc, re_rain_gsfc, re_ice_gsfc, &
- re_snow_gsfc, re_graupel_gsfc, re_hail_gsfc
-! NUWRF JJS 20140225 ^^^^^
-
- real, dimension( ims:ime, jms:jme, 1:4 ) :: sflxd !NUWRF SW only for LIS
-
-! REAL, DIMENSION(IMS:IME, JMS:JME, 1:4) :: flxd !NUWRF extra radiation output for LIS (CLM)
- ! 1-surface downward UV+VIS beam radiation [W/m2]
- ! 2-surface downward UV+VIS diffuse radiation [W/m2]
- ! 3-surface downward NIR beam radiation [W/m2]
- ! 4-surface downward NIR diffuse radiation [W/m2]
-
-
- real, dimension( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT) :: & !goddardrad
- cod2d_out ,& ! column optical depth
- ctop2d_out ! cloud top pressure [mb]
-
-! Added by ZCX for low and total cloud fraction
- REAL, DIMENSION( kms:kme ), OPTIONAL, INTENT(IN) :: znu ! eta values on half (mass)levels
- REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT) :: &
- cldt
-
-! Optional (only used by CAM lw scheme)
-
- REAL, DIMENSION( ims:ime, kms:kme, cam_abs_dim2, jms:jme ), OPTIONAL ,&
- INTENT(INOUT) :: abstot
- REAL, DIMENSION( ims:ime, kms:kme, cam_abs_dim1, jms:jme ), OPTIONAL ,&
- INTENT(INOUT) :: absnxt
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL ,&
- INTENT(INOUT) :: emstot
-
-!
-! Optional
-!
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
- OPTIONAL, &
- INTENT(INOUT) :: CLDFRA, &
- CCLDFRA,&
- QCCONV, &
- QICONV
-
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & ! ckay for sub-grid cloud fraction
- OPTIONAL, &
- INTENT(INOUT) :: cldfra_dp, &
- cldfra_sh, &
- cldfra_bl
-
-!..G. Thompson
- REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT):: re_cloud, re_ice, re_snow
- INTEGER, INTENT(INOUT):: has_reqc, has_reqi, has_reqs
-
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
- OPTIONAL, &
- INTENT(IN ) :: &
- F_ICE_PHY, &
- F_RAIN_PHY, &
- CLDFRA_MP_ALL
-
-#if (EM_CORE == 1)
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
- OPTIONAL, &
- INTENT(IN ) :: &
- LRADIUS, &
- IRADIUS
-#endif
-
- REAL, DIMENSION( ims:ime, jms:jme ), &
- OPTIONAL, &
- INTENT(OUT) :: SWDOWNC, SWDDIRC, SWDDNIC
-!
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
- OPTIONAL, &
- INTENT(INOUT ) :: &
- pb &
- ,qv,qc,qr,qi,qs,qg,qh,qndrop, &
- qnifa,qnwfa, & ! Trude
- qi2,qi3 ! for P3
-
- LOGICAL, OPTIONAL :: f_qv,f_qc,f_qr,f_qi,f_qs,f_qg,f_qh,f_qndrop,&
- f_qnifa,f_qnwfa, & ! trude
- f_qi2,f_qi3 ! for P3
- ! Solar diag
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(OUT), OPTIONAL :: qc_tot, qi_tot
-!shbaek
- real, dimension ( ims:ime, kms:kme, jms:jme ), optional, intent(in) :: qnc_curr
- LOGICAL, OPTIONAL :: f_qnc
-!
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
- OPTIONAL, &
- INTENT(INOUT) :: taucldi,taucldc
-
- REAL, OPTIONAL, INTENT(IN) :: dxkm
-
-! Variables for slope-dependent radiation
-
- REAL, OPTIONAL, INTENT(IN) :: dx,dy
- REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN), OPTIONAL :: dx2d, area2d
- INTEGER, OPTIONAL, INTENT(IN) :: slope_rad,topo_shading
- REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN) :: ht
- INTEGER, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN) :: shadowmask
- REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(OUT) :: diffuse_frac
-
- REAL , OPTIONAL, INTENT(INOUT) :: radtacttime ! Storing the time in s when radiation is called next
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
- INTENT(INOUT) :: o3rad
-
- ! begin WRF-CMAQ coupled model block
- REAL, DIMENSION (ims:ime, kms:kme, jms:jme ), optional, &
- INTENT(INOUT) :: mass_ws_i, mass_ws_j, mass_ws_k, &
- mass_in_i, mass_in_j, mass_in_k, &
- mass_ec_i, mass_ec_j, mass_ec_k, &
- mass_ss_i, mass_ss_j, mass_ss_k, &
- mass_h2o_i, mass_h2o_j, mass_h2o_k, &
- dgn_i, dgn_j, dgn_k, &
- sig_i, sig_j, sig_k
-
- REAL, DIMENSION (ims:ime, kms:kme, jms:jme ), optional, INTENT(OUT) :: sw_gtauxar_01, &
- sw_gtauxar_02, &
- sw_gtauxar_03, &
- sw_gtauxar_04, &
- sw_gtauxar_05, &
- sw_asy_fac_01, &
- sw_asy_fac_02, &
- sw_asy_fac_03, &
- sw_asy_fac_04, &
- sw_asy_fac_05, &
- sw_ssa_01, &
- sw_ssa_02, &
- sw_ssa_03, &
- sw_ssa_04, &
- sw_ssa_05
-
- REAL, DIMENSION( ims:ime, jms:jme ), optional, INTENT(OUT) :: sw_ttauxar_01, &
- sw_ttauxar_02, &
- sw_ttauxar_03, &
- sw_ttauxar_04, &
- sw_ttauxar_05
-
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), optional, INTENT(IN) :: ozone
- REAL, DIMENSION( ims:ime, jms:jme ), optional, INTENT(OUT) :: sw_zbbcddir, &
- sw_dirdflux, &
- sw_difdflux
-
- LOGICAL, INTENT(IN) :: feedback_is_ready
- ! end WRF-CMAQ coupled model block
-
- ! vert nesting
- REAL, OPTIONAL , INTENT(IN ) :: p_top
- REAL :: p_top_dummy
-
-! LOCAL VAR
- INTEGER, DIMENSION( ims:ime, kms:kme, jms:jme ) :: cldfra1_flag
- REAL, DIMENSION( ims:ime, jms:jme ) :: GLAT,GLON
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: CEMISS
- REAL, DIMENSION( ims:ime, jms:jme ) :: coszr
- REAL, DIMENSION( ims:ime, levsiz, jms:jme ) :: ozmixt
- REAL, DIMENSION( ims:ime, alevsiz, jms:jme, 1:no_src_types ) :: aerodt
-
- REAL :: DECLIN,SOLCON,XXLAT,TLOCTM,XT24, CEN_LAT, cldfra_cup_mod
- INTEGER :: i,j,k,its,ite,jts,jte,ij
- INTEGER :: STEPABS
- LOGICAL :: gfdl_lw,gfdl_sw, compute_cldfra_cup
- LOGICAL :: doabsems
- LOGICAL, EXTERNAL :: wrf_dm_on_monitor
- INTEGER :: s
- REAL :: ITRMX, &
- ITRMN
- REAL :: OBECL,SINOB,SXLONG,ARG,DECDEG, &
- DJUL,RJUL,ECCFAC
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: qc_temp
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: qi_save,qc_save
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: qs_save
-
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: qc_cu_weight
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: qi_cu_weight
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: qs_cu_weight
-
- REAL :: gridkm, Wice,Wh2o
- REAL, DIMENSION(kms:kme):: t_1d, p_1d, Dz_1d, qv_1d, qc_1d, qi_1d, qs_1d, cf_1d
-
- REAL :: next_rad_time, DTaccum
- LOGICAL :: run_param , doing_adapt_dt , decided
- LOGICAL :: flg_lw, flg_sw
-!ZCX
- REAL :: cldji,cldlji
-!ckay
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: cldfra_cu
-!------------------------------------------------------------------
-! solar related variables are added to declaration
-!-------------------------------------------------
- REAL, OPTIONAL, INTENT(OUT) :: DECLINX,SOLCONX
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme), INTENT(OUT) :: COSZEN
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme), INTENT(OUT) :: HRANG
-!------------------------------------------------------------------
-
-! jararias, 2013/08/10
- real :: ioh,kt,airmass,kd
- real, dimension(ims:ime,jms:jme) :: coszen_loc,hrang_loc
-! jararias 2013/11 but modified on 2016/2/10
-! the following three arrays may be dimensioned by (ims,ime,kms,kme,jms,jme,aerosol_vars)
- real, dimension(:,:,:,:), pointer :: tauaer_sw=>null(), ssaaer_sw=>null(), asyaer_sw=>null()
-!
-! Montornes-Cordian eclipse variables
- real, dimension(ims:ime,jms:jme), optional, INTENT(OUT) :: obscur
- integer, dimension(ims:ime,jms:jme), optional, INTENT(OUT) :: mask
- real, optional, INTENT(OUT) :: elat_track, elon_track
-! Local variables
- INTEGER, DIMENSION( ims:ime, jms:jme ) :: mask_loc
- REAL, DIMENSION( ims:ime, jms:jme ) :: obscur_loc
- REAL :: elat_loc, elon_loc
-
-! Trude AOD variables
- INTEGER, PARAMETER:: taer_type = 1 ! rural, urban, maritime, ...
- INTEGER, PARAMETER:: taer_aod550_opt = 2 ! input option for AOD at 550 nm
- INTEGER, PARAMETER:: taer_angexp_opt = 3 ! input option for aerosol Angstrom exponent
- INTEGER, PARAMETER:: taer_ssa_opt = 3 ! input option for aerosol ssa
- INTEGER, PARAMETER:: taer_asy_opt = 3 ! input option for aerosol asy
-
-
-#if ( HWRF == 1 )
- CHARACTER(len=255) :: wrf_err_message
-#endif
-
-!---------- local test vars
-! real, dimension(ims:ime, kms:kme, jms:jme) :: hlw, hsw
-
- LOGICAL :: proceed_twoway_sw
-
- logical, save :: firstime = .true.
- logical, save :: feedback_restart, direct_sw_feedback
-
-#if ( WRF_CMAQ == 1 )
- if (firstime) then
- firstime = .false.
- CALL nl_get_direct_sw_feedback ( .false. , direct_sw_feedback )
- CALL nl_get_feedback_restart ( .false. , feedback_restart )
- end if
-#else
- direct_sw_feedback = .false.
- feedback_restart = .false.
-#endif
-
- ! This allows radiation schemes (mainly HWRF) to correctly
- ! interface with the convection scheme when convection is only
- ! enabled in some domains:
- if(present(explicit_convection)) then
- expl_conv=explicit_convection
- else
- expl_conv=.true. ! backward compatibility for ARW
- endif
-
- IF ( ICLOUD == 3 ) THEN
- IF (PRESENT(dxkm)) then
- gridkm = 1.414*SQRT(dxkm*dxkm + dy*0.001*dy*0.001)
- ELSE IF (PRESENT(dx)) then
- gridkm = SQRT(dx*0.001*dx*0.001 + dy*0.001*dy*0.001)
- endif
-
- if (itimestep .LE. 100) then
- WRITE ( wrf_err_message , * ) 'Grid spacing in km ', dx, dy, gridkm
- CALL wrf_debug (100, wrf_err_message)
- endif
- END IF
-
- CALL wrf_debug (1, 'Top of Radiation Driver')
-! WRITE ( wrf_err_message , * ) 'itimestep = ',itimestep,', dt = ',dt,', lw and sw options = ',lw_physics,sw_physics
-! CALL wrf_debug (1, wrf_err_message )
- if (lw_physics .eq. 0 .and. sw_physics .eq. 0) return
-
-! amontornes-bcodina (2014-05-02) :: improving the namelist settings consistency for the FLG scheme
-! if (lw_physics .ne. FLGLWSCHEME .and. sw_physics .eq. FLGSWSCHEME) then
-! call wrf_error_fatal('SW and LW schemes are in conflict. SW is FLG and LW is a different scheme!')
-! end if
-! if (lw_physics .eq. FLGLWSCHEME .and. sw_physics .ne. FLGSWSCHEME) then
-! call wrf_error_fatal('SW and LW schemes are in conflict. LW is FLG and SW is a different scheme!')
-! end if
-
-! ra_call_offset = -1 gives old method where radiation may be called just before output
-! ra_call_offset = 0 gives new method where radiation may be called just after output
-! and is also consistent with removal of offset in new XTIME
-! also need to account for stepra=1 which always has zero modulo output
-
- doing_adapt_dt = .FALSE.
- IF ( PRESENT(adapt_step_flag) ) THEN
- IF ( adapt_step_flag ) THEN
- doing_adapt_dt = .TRUE.
- IF ( radtacttime .eq. 0. ) THEN
- radtacttime = CURR_SECS + radt*60.
- END IF
- END IF
- END IF
-
-! Do we run through this scheme or not?
-
-! Test 1: If this is the initial model time, then yes.
-! ITIMESTEP=1
-! Test 2: If the user asked for the radiation to be run every time step, then yes.
-! RADT=0 or STEPRA=1
-! Test 3: If not adaptive dt, and this is on the requested radiation frequency, then yes.
-! MOD(ITIMESTEP,STEPRA)=0 (or 1, depending on the offset setting)
-! Test 4: If using adaptive dt and the current time is past the last requested activate radiation time, then yes.
-! CURR_SECS >= RADTACTTIME
-
-! If we do run through the scheme, we set the flag run_param to TRUE and we set the decided flag
-! to TRUE. The decided flag says that one of these tests was able to say "yes", run the scheme.
-! We only proceed to other tests if the previous tests all have left decided as FALSE.
-
-! If we set run_param to TRUE and this is adaptive time stepping, we set the time to the next
-! radiation run.
-
- run_param = .FALSE.
- decided = .FALSE.
- IF ( ( .NOT. decided ) .AND. &
- ( itimestep .EQ. 1 ) ) THEN
- run_param = .TRUE.
- decided = .TRUE.
- END IF
-
- IF ( ( .NOT. decided ) .AND. &
- ( ( radt .EQ. 0. ) .OR. ( stepra .EQ. 1 ) ) ) THEN
- run_param = .TRUE.
- decided = .TRUE.
- END IF
-
- IF ( ( .NOT. decided ) .AND. &
- ( .NOT. doing_adapt_dt ) .AND. &
- ( MOD(itimestep,stepra) .EQ. 1+ra_call_offset ) ) THEN
- run_param = .TRUE.
- decided = .TRUE.
- END IF
-
- IF ( ( .NOT. decided ) .AND. &
- ( doing_adapt_dt ) .AND. &
- ( curr_secs .GE. radtacttime ) ) THEN
- run_param = .TRUE.
- decided = .TRUE.
- radtacttime = curr_secs + radt*60
- END IF
-
- IF ( mp_physics .EQ. nuwrf4icescheme ) THEN
- DO ij = 1 , num_tiles
- its = i_start(ij)
- ite = i_end(ij)
- jts = j_start(ij)
- jte = j_end(ij)
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- re_cloud(i,k,j) = re_cloud_gsfc(i,k,j) * 1.E-6
- re_ice(i,k,j) = re_ice_gsfc(i,k,j) * 1.E-6
- re_snow(i,k,j) = re_snow_gsfc(i,k,j) * 1.E-6
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- END IF
-
- if(swint_opt.eq.1 .or. swint_opt == 2) then
- DO ij = 1 , num_tiles
- its = i_start(ij)
- ite = i_end(ij)
- jts = j_start(ij)
- jte = j_end(ij)
- CALL radconst(XTIME,DECLIN,SOLCON,JULIAN, &
- DEGRAD,DPD )
- call calc_coszen(ims,ime,jms,jme,its,ite,jts,jte, &
- julian,xtime,gmt,declin,degrad, &
- xlong,xlat,coszen_loc,hrang_loc)
- end do
- end if
-
- solar_opt_local = 0
- IF ( PRESENT(solar_opt) ) THEN
- solar_opt_local = solar_opt
- END IF
- Solar_step: IF (run_param .or. solar_opt_local == 1 .or. swint_opt == 2) THEN
-
- !---------------
- ! Calculate constant for short wave radiation
- ! moved up and out of OMP loop because it only needs to be computed once
- ! and because it is not entirely thread-safe (XT24, TOLOCTM and XXLAT need
- ! their thread-privacy) JM 20100217
- DO ij = 1 , num_tiles
- its = i_start(ij)
- ite = i_end(ij)
- jts = j_start(ij)
- jte = j_end(ij)
- CALL radconst(XTIME,DECLIN,SOLCON,JULIAN, &
- DEGRAD,DPD )
-
-! amontornes-bcodina 2015/09 solar eclipses
-! Solar eclipse prediction based on the Bessel's method
-! outputs: obscur, mask, elat_track, elon_track
- CALL solar_eclipse(ims,ime,jms,jme,its,ite,jts,jte, &
- julian,gmt,YR,xtime,radt, &
- degrad,xlong,xlat,obscur_loc,mask_loc, &
- elat_loc,elon_loc,sw_eclipse )
-
- IF(PRESENT(declinx).AND.PRESENT(solconx))THEN
-! saved to state arrays used in surface driver
- declinx=declin
- solconx=solcon
- ENDIF
-! added coszen subroutine : jararias, 2013/08/10
-! outputs: coszen, hrang
- call calc_coszen(ims,ime,jms,jme,its,ite,jts,jte, &
- julian,xtime+radt*0.5,gmt, &
- declin,degrad,xlong,xlat,coszen,hrang)
-
- ! backup the incoming hydrometeors
-
- IF ( F_QC ) THEN
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- qc_save(i,k,j) = qc(i,k,j)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- IF ( F_QI ) THEN
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- qi_save(i,k,j) = qi(i,k,j)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- IF(aercu_opt.gt.0.0) THEN
- IF ( F_QI ) THEN
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- qs_save(i,k,j) = qs(i,k,j)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- END IF
-
-! Fill temporary water variable depending on micro package (tgs 25 Apr 2006)
- if( F_QC ) then
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- qc_temp(I,K,J)=qc(I,K,J)
- ENDDO
- ENDDO
- ENDDO
- else
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- qc_temp(I,K,J)=0.
- ENDDO
- ENDDO
- ENDDO
- endif
-! Remove this - to match NAM operational (affects GFDL and HWRF schemes)
-! if( F_QR ) then
-! DO j=jts,jte
-! DO k=kts,kte
-! DO i=its,ite
-! qc_temp(I,K,J) = qc_temp(I,K,J) + qr(I,K,J)
-! ENDDO
-! ENDDO
-! ENDDO
-! endif
-!
-! temporarily modify hydrometeors (this is for GD scheme and WRF-Chem)
-!
- IF ( F_QC .AND. icloud_cu .EQ. 1 ) THEN
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- qc(i,k,j) = qc(i,k,j) + qc_cu(i,k,j)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- IF ( F_QI .AND. icloud_cu .EQ. 1 ) THEN
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- qi(i,k,j) = qi(i,k,j) + qi_cu(i,k,j)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
-#if (EM_CORE == 1)
-! temporarily modify hydrometeors (for P3, if 2 cat then add ice from both categories)
-!
- IF ( F_QI2) THEN
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- qi(i,k,j) = qi(i,k,j) + qi2(i,k,j)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
-! for Jensen ISHMAEL, add the third ice species
- IF ( F_QI3) THEN
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- qi(i,k,j) = qi(i,k,j) + qi3(i,k,j)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-#endif
-
-! Choose how to compute cloud fraction (since 3.6)
-! Initialize to zero
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- CLDFRA(i,k,j) = 0.
- END DO
- END DO
- END DO
-!---------------
-! Calculate constant for short wave radiation
-
- IF ( ICLOUD == 1 ) THEN
-
- IF ( F_QC .OR. F_QI ) THEN
-! Call to cloud fraction routine based on Randall 1994 (Hong Pan 1998)
-
- CALL wrf_debug (1, 'CALL cldfra1')
- CALL cal_cldfra1(CLDFRA,qv,qc,qi,qs, &
- F_QV,F_QC,F_QI,F_QS,t,p, &
- F_ICE_PHY,F_RAIN_PHY, &
- mp_physics,cldfra1_flag, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte )
- IF ( PRESENT ( CLDFRA_DP ) ) THEN
-! this is for Kain-Fritsch schemes
- IF ( icloud_cu .EQ. 2 .OR. aercu_opt .GT. 0 ) THEN
- CALL wrf_debug (1, 'use kf cldfra')
- DO j = jts,jte
- DO k = kts,kte
- DO i = its,ite
- cldfra_cu(i,k,j)=cldfra_dp(i,k,j)+cldfra_sh(i,k,j) ! Cu cloud fraction
- CLDFRA(i,k,j)=(1.-cldfra_cu(i,k,j))*CLDFRA(i,k,j) ! Update resolved cloud fraction for Cu punch-through
- CLDFRA(i,k,j)=CLDFRA(i,k,j)+cldfra_cu(i,k,j) ! New total cloud fraction
- CLDFRA(i,k,j)=AMIN1(1.0,CLDFRA(i,k,j))
- qc(i,k,j) = qc(i,k,j)+qc_cu(i,k,j)*cldfra_cu(i,k,j)
- qi(i,k,j) = qi(i,k,j)+qi_cu(i,k,j)*cldfra_cu(i,k,j)
- ENDDO
- ENDDO
- ENDDO
- IF (aercu_opt.gt.0.0) THEN
- DO j = jts,jte
- DO k = kts,kte
- DO i = its,ite
- IF (qc(i,k,j).eq.0.0.and.qc_cu(i,k,j).gt.0.0) THEN
- qc_cu_weight(i,k,j) = 1.0
- ELSE IF (qc(i,k,j).gt.0.0.and.qc_cu(i,k,j).eq.0.0) THEN
- qc_cu_weight(i,k,j) = 0.0
- ELSE IF (qc(i,k,j).eq.0.0.and.qc_cu(i,k,j).eq.0.0) THEN
- qc_cu_weight(i,k,j) = 0.0
- ELSE
- qc_cu_weight(i,k,j) = (qc_cu(i,k,j)*cldfra_cu(i,k,j))/(qc(i,k,j) + qc_cu(i,k,j)*cldfra_cu(i,k,j))
- END IF
- IF (qi(i,k,j).eq.0.0.and.qi_cu(i,k,j).gt.0.0) THEN
- qi_cu_weight(i,k,j) = 1.0
- ELSE IF (qi(i,k,j).gt.0.0.and.qi_cu(i,k,j).eq.0.0) THEN
- qi_cu_weight(i,k,j) = 0.0
- ELSE IF (qi(i,k,j).eq.0.0.and.qi_cu(i,k,j).eq.0.0) THEN
- qi_cu_weight(i,k,j) = 0.0
- ELSE
- qi_cu_weight(i,k,j) =(qi_cu(i,k,j)*cldfra_cu(i,k,j))/(qi(i,k,j) + qi_cu(i,k,j)*cldfra_cu(i,k,j))
- END IF
- IF (qs(i,k,j).eq.0.0.and.qs_cu(i,k,j).gt.0.0) THEN
- qs_cu_weight(i,k,j) = 1.0
- ELSE IF (qs(i,k,j).gt.0.0.and.qs_cu(i,k,j).eq.0.0) THEN
- qs_cu_weight(i,k,j) = 0.0
- ELSE IF (qs(i,k,j).eq.0.0.and.qs_cu(i,k,j).eq.0.0) THEN
- qs_cu_weight(i,k,j) = 0.0
- ELSE
- qs_cu_weight(i,k,j)=(qs_cu(i,k,j)*cldfra_cu(i,k,j))/(qs(i,k,j) + qs_cu(i,k,j)*cldfra_cu(i,k,j))
- END IF
-
-! use re_cloud, re_ice and re_snow to store combined effective radii from MSKF and Morrison microphysics
- re_cloud(i,k,j) = EFCS(I,K,J)*qc_cu_weight(I,K,J) &
- + EFCG(I,K,J)*(1-qc_cu_weight(I,K,J))
- re_cloud(i,k,j) = re_cloud(i,k,j) * 1.E-6
- re_ice(i,k,j) = EFIS(I,K,J)*qi_cu_weight(I,K,J) &
- + EFIG(I,K,J)*(1-qi_cu_weight(I,K,J))
- re_ice(i,k,j) = re_ice(i,k,j) * 1.E-6
- re_snow(i,k,j) = EFSS(I,K,J)*qs_cu_weight(I,K,J) &
- + EFSG(I,K,J)*(1-qs_cu_weight(I,K,J))
- re_snow(i,k,j) = re_snow(i,k,j) * 1.E-6
- has_reqc = 1
- has_reqi = 1
- has_reqs = 1
- qs(i,k,j) = qs(i,k,j)+qs_cu(i,k,j)*cldfra_cu(i,k,j)
-
- ENDDO
- ENDDO
- ENDDO
- END IF
- ENDIF
- ENDIF
-
- IF ( PRESENT ( CLDFRA_BL ) .AND. PRESENT ( QC_BL ) ) THEN
- IF ( icloud_bl > 0 ) THEN
- CALL wrf_debug (1, 'in rad driver; use BL clouds')
- IF (itimestep .NE. 1) THEN
- DO j = jts,jte
- DO i = its,ite
- DO k = kts,kte
- CLDFRA(i,k,j)=CLDFRA_BL(i,k,j)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- DO j = jts,jte
- DO i = its,ite
- DO k = kts,kte
- IF (qc(i,k,j) < 1.E-6 .AND. CLDFRA_BL(i,k,j) > 0.001) THEN
- qc(i,k,j)=qc(i,k,j) + QC_BL(i,k,j)*CLDFRA_BL(i,k,j)
- ENDIF
- IF (qi(i,k,j) < 1.E-8 .AND. CLDFRA_BL(i,k,j) > 0.001) THEN
- qi(i,k,j)=qi(i,k,j) + QI_BL(i,k,j)*CLDFRA_BL(i,k,j)
- ENDIF
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- ENDIF
-
- IF ( PRESENT (cldfra_mp_all) ) THEN
- IF (is_CAMMGMP_used) THEN
- !BSINGH: cloud fraction from CAMMGMP is being used (Mods by Po-Lun)
- CALL wrf_debug (1, 'use cammgmp')
- IF (itimestep .NE. 1) THEN
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- CLDFRA(i,k,j) = CLDFRA_MP_ALL(I,K,J) !PMA
- if (CLDFRA(i,k,j) .lt. 0.01) CLDFRA(i,k,j) = 0.
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- ENDIF
- ENDIF
- ENDIF
-
- ELSE IF ( ICLOUD == 2 ) THEN
- IF ( F_QC .OR. F_QI ) THEN
- CALL wrf_debug (1, 'CALL cldfra2')
- CALL cal_cldfra2(CLDFRA,qc,qi,F_QC,F_QI, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte )
- ENDIF
-
-!+---+-----------------------------------------------------------------+
-!..New cloud fraction scheme added by G. Thompson (2014Oct31)
-!+---+-----------------------------------------------------------------+
-
- ELSEIF (ICLOUD == 3) THEN
- IF ( F_QC .AND. F_QI ) THEN
-
- CALL wrf_debug (150, 'DEBUG: using gthompsn cloud fraction scheme')
-
- DO j = jts,jte
- DO i = its,ite
-
- DO k = kts,kte
- p_1d(k) = p(i,k,j)
- t_1d(k) = t(i,k,j)
- qv_1d(k) = qv(i,k,j)
- qc_1d(k) = qc(i,k,j)
- qi_1d(k) = qi(i,k,j)
- qs_1d(k) = qs(i,k,j)
- Dz_1d(k) = dz8w(i,k,j)
- cf_1d(k) = cldfra(i,k,j)
- ENDDO
-
- WRITE (wrf_err_message,*) 'DEBUG: calling cal_cldfra3 at (i,j): ', i,j, kms,kme,kts,kte
- CALL wrf_debug (150, wrf_err_message)
-
- CALL cal_cldfra3(cf_1d, qv_1d, qc_1d, qi_1d, qs_1d, Dz_1d, &
- & p_1d, t_1d, XLAND(i,j), gridkm, &
- & .false., 1.5, kts, kte, .false.)
-
- DO k = kts,kte
- qc(i,k,j) = qc_1d(k)
- qi(i,k,j) = qi_1d(k)
- qs(i,k,j) = qs_1d(k)
- cldfra(i,k,j) = cf_1d(k)
- ENDDO
-
- ENDDO
- ENDDO
-
- ELSE
- CALL wrf_error_fatal('Can not use icloud = 3 option, missing QC or QI field.')
- ENDIF
-
- END IF
-
- !Modify CLDFRA and QC for kfcupscheme cumulus scheme
- if(present(cldfra_cup)) then
- !BSINGH - overwrite cldfra with the cloud fraction computed in module_cu_kfcup.F
- !Force cloud fraction if cumulus triggered.
- if( cu_physics == KFCUPSCHEME ) then
- do j = jts,jte
- do k = kts,kte
- do i = its,ite
-
- !Find whether to overwrite cldfra or not (ONLY if ICLOUD == 1)
- compute_cldfra_cup = .true.
- if (icloud == 1 ) then
- compute_cldfra_cup = .false. !-- LK Berg, 4/26/17
- if(cldfra1_flag(i,k,j) == 1 .and. shall(i,j) .gt. 1) then
- CLDFRA(i,k,j)=0.
- elseif(cldfra1_flag(i,k,j) == 1 .and. shall(i,j) .le. 1) then
- CLDFRA(i,k,j)=0.
- compute_cldfra_cup = .true. ! No resolved clouds, but check of shallow clouds. -- LK Berg, 4/26/17
- elseif(cldfra1_flag(i,k,j) == 2 .and. shall(i,j) .gt. 1) then
- CLDFRA(i,k,j)=1.
- elseif(cldfra1_flag(i,k,j) == 3) then
- compute_cldfra_cup = .true.
- endif
- endif
-
-
- if(compute_cldfra_cup) then
- if( (int(shall(i,j)) .le.1) .and. k >= int(cubot(i,j)) .and. k <= int(cutop(i,j)) ) then ! LD Mar232012
- CLDFRA(i,k,j) = cldfra_cup(i,k,j)
- else if( shall(i,j) .gt. 1) then !!LD
- cldfra_cup(i,k,j) = 0.0
- end if
- endif
- if( shall(i,j) <= 1 .and. k >= cubot(i,j) .and. k <= cutop(i,j) ) then ! 1=Shallow Cu -- Changed to use for both deep and shallow -- LK Berg 4/26/17
- ! Begin: wig, 4-Feb-2008
- !
- ! Override the cloud condensate values if shallow convection triggered.
- ! For shallow convection, use a representative condensate value based on
- ! observations from CHAPS (Oklahoma area) and Florida (Blyth et al. 2005)
- ! or the predicted value if it is greater.
-
- cldfra_cup_mod = cldfra_cup(i,k,j) * 1.0e-3 !modified cloud fraction, assume QCLOUD is 1 g/kg -- LK Berg 4/26/17
- qc(i,k,j) = max(cldfra_cup_mod, qc(i,k,j) )!DE+LB 2012-Feb
-
- ! Override the cloud fraction values calculated above if shallow
- ! convection triggered. For shallow convection, use a representative
- ! cloud fraction. In this case, the median value for shallow Cu cases
- ! at the ARM SGP site, 36%, Berg et al. 2008, J. Clim.
- if( shallowcu_forced_ra )cldfra(i,k,j) = max(0.36, cldfra(i,k,j)) ! Median shallow Cu frac at ARM SGP
- endif
- ENDDO
- ENDDO
- ENDDO
- end if
- endif
-
-#if (EM_CORE==1)
- IF( shcu_physics == 5 ) THEN
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- cldfra(I,K,J) = max(cldfra_sh(I,K,J), cldfra(I,K,J))
- qc(I,K,J)=cw_rad(I,K,J)+qc(I,K,J)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-#endif
-
- IF ( cu_physics == BMJSCHEME .AND. bmj_rad_feedback .EQV. .TRUE. ) THEN
-! hydrometeors from microphysics scheme have saved in q*_save
-! Modify cloud fraction and temporarily hydrometeors (PCC scheme)
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- qc(i,k,j) = qc(i,k,j) + QCCONV(i,k,j)
- qi(i,k,j) = qi(i,k,j) + QICONV(i,k,j)
- ITRMX=MIN(cldfra(i,k,j),ccldfra(i,k,j))
- ITRMN=MAX(0.,cldfra(i,k,j)+ccldfra(i,k,j)-1.)
- cldfra(i,k,j)=cldfra(i,k,j)+ccldfra(i,k,j)-0.5*(ITRMX+ITRMN)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
-
- END DO
-
- ENDIF Solar_step
-
- Radiation_step: IF ( run_param ) then
-! CAM-specific additional radiation frequency - cam_abs_freq_s (=21600s by default)
- STEPABS = nint(cam_abs_freq_s/(dt*STEPRA))*STEPRA
- IF (itimestep .eq. 1 .or. mod(itimestep,STEPABS) .eq. 1 + ra_call_offset &
- .or. STEPABS .eq. 1 ) THEN
- doabsems = .true.
- ELSE
- doabsems = .false.
- ENDIF
- IF (PRESENT(adapt_step_flag)) THEN
- IF ((adapt_step_flag)) THEN
- IF ( (itimestep .EQ. 1) .OR. (cam_abs_freq_s .EQ. 0) .OR. &
- ( CURR_SECS + dt >= ( INT( CURR_SECS / ( cam_abs_freq_s ) + 1 ) * cam_abs_freq_s) ) ) THEN
- doabsems = .true.
- ELSE
- doabsems = .false.
- ENDIF
- ENDIF
- ENDIF
-
- gfdl_lw = .false.
- gfdl_sw = .false.
- flg_lw = .false.
- flg_sw = .false.
-
-! Allocate aerosol arrays used by aer_opt = 2 option
- IF ( PRESENT( AOD5502D ) ) THEN
- ! jararias, 2013/11
- IF ( aer_opt .EQ. 2 ) THEN
- swrad_aerosol_select: select case(sw_physics)
-
- case(GODDARDSWSCHEME)
- allocate(tauaer_sw(ims:ime, kms:kme, jms:jme, 1:11))
- allocate(ssaaer_sw(ims:ime, kms:kme, jms:jme, 1:11))
- allocate(asyaer_sw(ims:ime, kms:kme, jms:jme, 1:11))
-
- case(RRTMG_SWSCHEME &
-#if( BUILD_RRTMG_FAST == 1)
- ,RRTMG_SWSCHEME_FAST &
-#endif
-#if( BUILD_RRTMK == 1)
- ,RRTMK_SWSCHEME &
-#endif
- )
- allocate(tauaer_sw(ims:ime, kms:kme, jms:jme, 1:14))
- allocate(ssaaer_sw(ims:ime, kms:kme, jms:jme, 1:14))
- allocate(asyaer_sw(ims:ime, kms:kme, jms:jme, 1:14))
-
- end select swrad_aerosol_select
- ENDIF
- ENDIF
-
-! Allocate aerosol arrays used by aer_opt = 3 option, and explicit AOD from QNWFA+QNIFA (Trude)
- IF (PRESENT(f_qnwfa) .AND. PRESENT(f_qnifa) .AND. PRESENT(taod5503d) .AND. PRESENT(taod5502d)) THEN
- IF (F_QNWFA .AND. aer_opt.eq.3 .AND. &
- (sw_physics.eq.RRTMG_SWSCHEME &
-#if( BUILD_RRTMG_FAST == 1)
- .OR. sw_physics.eq.RRTMG_SWSCHEME_FAST &
-#endif
-#if( BUILD_RRTMK == 1)
- .OR. sw_physics.eq.RRTMK_SWSCHEME &
-#endif
- )) THEN
- CALL wrf_debug (150, 'DEBUG-GT: computing 3D AOD from QNWFA+QNIFA')
-
- allocate(tauaer_sw(ims:ime, kms:kme, jms:jme, 1:14))
- allocate(ssaaer_sw(ims:ime, kms:kme, jms:jme, 1:14))
- allocate(asyaer_sw(ims:ime, kms:kme, jms:jme, 1:14))
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij ,i,j,k,its,ite,jts,jte)
- DO ij = 1 , num_tiles
- its = i_start(ij)
- ite = i_end(ij)
- jts = j_start(ij)
- jte = j_end(ij)
-
- do j=jts,jte
- do i=its,ite
- taod5502d(i,j) = 0.0
- end do
- end do
-
- call gt_aod (p, DZ8W, t, qv, qnwfa, qnifa, taod5503d, &
- ims,ime, jms,jme, kms,kme,its,ite, jts,jte, kts,kte)
-
- do j=jts,jte
- do i=its,ite
- do k=kts,kte
- taod5502d(i,j) = taod5502d(i,j) + taod5503d(i,k,j)
- end do
- end do
- end do
- ENDDO
- !$OMP END PARALLEL DO
- ENDIF
- ENDIF
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij ,i,j,k,its,ite,jts,jte)
-
- DO ij = 1 , num_tiles
- its = i_start(ij)
- ite = i_end(ij)
- jts = j_start(ij)
- jte = j_end(ij)
-
-! initialize data
-
- if ((itimestep.eq.1).and.(swint_opt.eq.1)) then
- do j=jts,jte
- do i=its,ite
- Bx(i,j)=0.
- bb(i,j)=0.
- Gx(i,j)=0.
- gg(i,j)=0.
- end do
- end do
- end if
-
- DO j=jts,jte
- DO i=its,ite
- GSW(I,J)=0.
- GLW(I,J)=0.
- SWDOWN(I,J)=0.
- swddir(i,j)=0. ! jararias, 2013/08/10
- swddni(i,j)=0. ! jararias, 2013/08/10
- swddif(i,j)=0. ! jararias, 2013/08/10
- GLAT(I,J)=XLAT(I,J)*DEGRAD
- GLON(I,J)=XLONG(I,J)*DEGRAD
- ENDDO
- ENDDO
-
- DO j=jts,jte
- DO k=kts,kte+1
- DO i=its,ite
- RTHRATEN(I,K,J)=0.
- RTHRATENLW(I,K,J)=0.
- RTHRATENLWC(I,K,J)=0.
- RTHRATENSW(I,K,J)=0.
- RTHRATENSWC(I,K,J)=0.
- CEMISS(I,K,J)=0.0
- ENDDO
- ENDDO
- ENDDO
-
- IF ( PRESENT( SWUPFLX ) ) THEN
- DO j=jts,jte
- DO k=kts,kte+2
- DO i=its,ite
- SWUPFLX(I,K,J) = 0.0
- SWDNFLX(I,K,J) = 0.0
- SWUPFLXC(I,K,J) = 0.0
- SWDNFLXC(I,K,J) = 0.0
- LWUPFLX(I,K,J) = 0.0
- LWDNFLX(I,K,J) = 0.0
- LWUPFLXC(I,K,J) = 0.0
- LWDNFLXC(I,K,J) = 0.0
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
-! these are half level parameters.....so, it should start from kts to kte - 1
-!NUWRF JJS 20101021 vvvvv
-#if ( WRF_CHEM == 1)
-! Pack gocart aerosol species
-! All aerosol species in chem are in "ug/kg-dryair"
-! and conerted to (g/m**3)
-
- aero(:,:,:,:) = 0.
- if ( (chem_opt == 300 .or. chem_opt == 301 .or. &
- chem_opt == 302 .or. chem_opt == 303) .and. &
- (gsfcrad_gocart_coupling == 1) ) then
- do j = jts, jte
- do k = kts, kte !corrected memory order
- do i = its, ite
- ! aero(i,k,j, 1) = max(0.0, chem(i,k,j,p_sulf)*1.0e-6*rho(i,k,j)) ! 1 = SO4
- aero(i,k,j, 1) = max(0.0, chem(i,k,j,p_sulf)*1.0e-6*p(i,k,j)*96.0/(8.314*t(i,k,j))) ! 1 = SO4
- aero(i,k,j, 2) = max(0.0, (chem(i,k,j,p_bc1)+chem(i,k,j,p_bc2))*1.0e-6*rho(i,k,j)) ! 2 = BC1+BC2
- aero(i,k,j, 3) = max(0.0, chem(i,k,j,p_oc1)*1.0e-6*rho(i,k,j)*1.4e0) ! 3 = OC1
- aero(i,k,j, 4) = max(0.0, chem(i,k,j,p_oc2)*1.0e-6*rho(i,k,j)*1.4e0) ! 4 = OC2
- aero(i,k,j, 5) = max(0.0, chem(i,k,j,p_seas_1)*1.0e-6*rho(i,k,j)) ! 5 = SS1
- aero(i,k,j, 6) = max(0.0, (chem(i,k,j,p_seas_2)+chem(i,k,j,p_seas_3)+ &
- chem(i,k,j,p_seas_4))*1.0e-6*rho(i,k,j)) ! 6 = SS2+SS3+SS4
- aero(i,k,j, 7) = max(0.0, chem(i,k,j,p_dust_1)*1.0e-6*rho(i,k,j)*frac(1)) ! 7 = DU1 dust mode 1
- aero(i,k,j, 8) = max(0.0, chem(i,k,j,p_dust_1)*1.0e-6*rho(i,k,j)*frac(2)) ! 8 = DU1 dust mode 2
- aero(i,k,j, 9) = max(0.0, chem(i,k,j,p_dust_1)*1.0e-6*rho(i,k,j)*frac(3)) ! 9 = DU1 dust mode 3
- aero(i,k,j,10) = max(0.0, chem(i,k,j,p_dust_1)*1.0e-6*rho(i,k,j)*frac(4)) ! 10 = DU1 dust mode 4
- aero(i,k,j,11) = max(0.0, chem(i,k,j,p_dust_2)*1.0e-6*rho(i,k,j)) ! 11 = DU2 dust mode 5
- aero(i,k,j,12) = max(0.0, chem(i,k,j,p_dust_3)*1.0e-6*rho(i,k,j)) ! 11 = DU3 dust mode 6
- aero(i,k,j,13) = max(0.0, chem(i,k,j,p_dust_4)*1.0e-6*rho(i,k,j)) ! 11 = DU4 dust mode 7
- aero(i,k,j,14) = max(0.0, chem(i,k,j,p_dust_5)*1.0e-6*rho(i,k,j)) ! 11 = DU5 dust mode 8
- enddo ! i
- enddo ! k
- enddo ! j
- end if ! if (gsfcrad_gocart_coupling == 1)
-#endif
-!NUWRF JJS 20101021 ^^^^^
-
-! Interpolating climatological ozone and aerosol to model time and levels
-! Adapted from camrad code
-#if (EM_CORE==1)
- IF ( o3input .EQ. 2 .AND. id .EQ. 1 ) THEN
-#else
- IF ( o3input .EQ. 2 ) THEN
-#endif
-! ! Find the current month (adapted from Cavallo)
-! CALL cam_time_interp( ozmixm, pin, levsiz, date_str, &
-! ids , ide , jds , jde , kds , kde , &
-! ims , ime , jms , jme , kms , kme , &
-! its , ite , jts , jte , kts , kte )
-! this is the CAM version
-! interpolate to model time-step
- call ozn_time_int(julday,julian,ozmixm,ozmixt,levsiz,n_ozmixm, &
- ids , ide , jds , jde , kds , kde , &
- ims , ime , jms , jme , kms , kme , &
- its , ite , jts , jte , kts , kte )
-
-! interpolate to model model levels
- call ozn_p_int(p ,pin, levsiz, ozmixt, o3rad, &
- ids , ide , jds , jde , kds , kde , &
- ims , ime , jms , jme , kms , kme , &
- its , ite , jts , jte , kts , kte )
- ENDIF
-
- IF ( PRESENT( AEROD ) ) THEN
- IF ( aer_opt .EQ. 1 .AND. id .EQ. 1 ) THEN
- call aer_time_int(julday,julian,aerodm,aerodt,alevsiz,n_ozmixm-1,no_src_types, &
- ids , ide , jds , jde , kds , kde , &
- ims , ime , jms , jme , kms , kme , &
- its , ite , jts , jte , kts , kte )
-
- call aer_p_int(p ,pina, alevsiz, aerodt, aerod, no_src_types, p8w, AODTOT, &
- ids , ide , jds , jde , kds , kde , &
- ims , ime , jms , jme , kms , kme , &
- its , ite , jts , jte , kts , kte )
- ENDIF
- ENDIF
-
- lwrad_select: SELECT CASE(lw_physics)
-
- CASE (RRTMSCHEME)
- CALL wrf_debug (100, 'CALL rrtm')
-
- IF ( PRESENT(p_top) ) THEN
- p_top_dummy = p_top
- ELSE
- p_top_dummy = -1. ! not used by NMM
- END IF
-
- CALL RRTMLWRAD( &
- P_TOP=p_top_dummy &
- ,RTHRATEN=RTHRATEN,RTHRATENC=RTHRATENLWC,GLW=GLW &
- ,OLR=RLWTOA,EMISS=EMISS &
- ,QV3D=QV &
- ,QC3D=QC &
- ,QR3D=QR &
- ,QI3D=QI &
- ,QS3D=QS &
- ,QG3D=QG &
- ,P8W=p8w,P3D=p,PI3D=pi,DZ8W=dz8w,TSK=tsk,T3D=t &
- ,T8W=t8w,RHO3D=rho,CLDFRA3D=CLDFRA,R=R_d,G=G &
- ,F_QV=F_QV,F_QC=F_QC,F_QR=F_QR &
- ,F_QI=F_QI,F_QS=F_QS,F_QG=F_QG &
- ,ICLOUD=icloud,WARM_RAIN=warm_rain &
-!ccc Added for time-varying trace gases.
- ,YR=YR,JULIAN=JULIAN &
-!ccc
- ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &
- ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
- ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte &
- )
-
-
-! NUWRF Version by Toshihisa Matsui and Jainn Shi 20090623
- case (goddardlwscheme)
-
- CALL wrf_debug(100, 'CALL NUWRF goddard longwave radiation scheme 2017')
-
- IF ( mp_physics .NE. nuwrf4icescheme ) THEN
- IF ( has_reqc .EQ. 1 ) THEN
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- re_cloud_gsfc(i,k,j) = re_cloud(i,k,j) * 1.E+6
- re_ice_gsfc(i,k,j) = re_ice(i,k,j) * 1.E+6
- re_snow_gsfc(i,k,j) = re_snow(i,k,j) * 1.E+6
- re_rain_gsfc(i,k,j) = 0.
- re_graupel_gsfc(i,k,j) = 0.
- re_hail_gsfc(i,k,j) = 0.
- ENDDO
- ENDDO
- ENDDO
- ELSE
- WRITE ( wrf_err_message , * ) 'Must choose a microphysics that provides effective radii.'
- CALL wrf_debug (0, wrf_err_message)
- END IF
- END IF
-
- CALL goddardrad(sw_or_lw='lw',dx=dx &
- ,rthraten=rthraten,gsf=glw,xlat=xlat,xlong=xlong &
- ,alb=albedo,t3d=t,p3d=p,p8w3d=p8w,pi3d=pi &
- ,dz8w=dz8w,rho_phy=rho,emiss=emiss,tsk=tsk &
- ,cldfra3d=cldfra &
- ,gmt=gmt,cp=cp,g=g,t8w=t8w &
- ,julday=julday,xtime=xtime &
- ,declin=declin,solcon=solcon &
- ,radfrq=radt,degrad=degrad &
- ,warm_rain=warm_rain &
- ,ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde &
- ,ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme &
- ,its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte &
- ,qv=qv,qc=qc,qi=qi,qr=qr,qs=qs,qg=qg,qh=qh &
- ,f_qv=f_qv,f_qc=f_qc,f_qr=f_qr &
- ,f_qi=f_qi,f_qs=f_qs,f_qg=f_qg ,f_qh=f_qh &
- ,rec3d=re_cloud_gsfc,rei3d=re_ice_gsfc &
- ,rer3d=re_rain_gsfc,res3d=re_snow_gsfc & !optional
- ,reg3d=re_graupel_gsfc,reh3d=re_hail_gsfc & !optional
- ,erbe_out=erbe_out &
- ,itimestep=itimestep, dt_in = dt &
- ,obscur=obscur_loc &
-#if (WRF_CHEM == 1)
- ,AERO=aero &
- ,CHEM_OPT=chem_opt &
- ,GSFCRAD_GOCART_COUPLING=gsfcrad_gocart_coupling &
-#endif
- )
-
-
- CASE (GFDLLWSCHEME)
-
- CALL wrf_debug (100, 'CALL gfdllw')
-
- IF ( PRESENT(F_QV) .AND. PRESENT(F_QC) .AND. &
- PRESENT(F_QI) .AND. (PRESENT(qi) .OR. PRESENT(qs)) .AND. &
- PRESENT(qv) .AND. PRESENT(qc) ) THEN
- IF ( F_QV .AND. F_QC .AND. (F_QI .OR. F_QS)) THEN
- gfdl_lw = .true.
- CALL ETARA( &
- DT=dt,XLAND=xland &
- ,P8W=p8w,DZ8W=dz8w,RHO_PHY=rho,P_PHY=p,T=t &
- ,QV=qv,QW=qc_temp,QI=qi,QS=qs &
- ,TSK2D=tsk,GLW=GLW,RSWIN=SWDOWN,GSW=GSW &
- ,RSWINC=SWDOWNC,CLDFRA=CLDFRA,PI3D=pi &
- ,GLAT=glat,GLON=glon,HTOP=htop,HBOT=hbot &
- ,HBOTR=hbotr, HTOPR=htopr &
- ,ALBEDO=albedo,CUPPT=cuppt &
- ,VEGFRA=vegfra,SNOW=snow,G=g,GMT=gmt &
- ,NSTEPRA=stepra,NPHS=nphs,ITIMESTEP=itimestep &
- ,XTIME=xtime,JULIAN=julian &
- ,JULYR=julyr,JULDAY=julday &
- ,GFDL_LW=gfdl_lw,GFDL_SW=gfdl_sw &
- ,CFRACL=cfracl,CFRACM=cfracm,CFRACH=cfrach &
- ,ACFRST=acfrst,NCFRST=ncfrst &
- ,ACFRCV=acfrcv,NCFRCV=ncfrcv &
- ,RSWTOA=rswtoa,RLWTOA=rlwtoa,CZMEAN=czmean &
- ,THRATEN=rthraten,THRATENLW=rthratenlw &
- ,THRATENSW=rthratensw &
- ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &
- ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
- ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte &
- )
- ELSE
- CALL wrf_error_fatal('Can not call ETARA (1a). Missing moisture fields.')
- ENDIF
- ELSE
- CALL wrf_error_fatal('Can not call ETARA (1b). Missing moisture fields.')
- ENDIF
-
-#if ( HWRF == 1 )
- CASE (HWRFLWSCHEME)
-
- CALL wrf_debug (100, 'CALL hwrflw')
-
- gfdl_lw = .true.
-
- CALL HWRFRA(explicit_convection=expl_conv, &
- DT=dt,thraten=RTHRATEN,thratenlw=RTHRATENLW,thratensw=RTHRATENSW,pi3d=pi, &
- XLAND=xland,P8w=p8w,DZ8w=dz8w,RHO_PHY=rho,P_PHY=p,T=t, &
- QV=qv,QW=qc_temp,QI=Qi, &
- TSK2D=tsk,GLW=GLW,GSW=GSW, &
- TOTSWDN=swdown,TOTLWDN=glw,RSWTOA=rswtoa,RLWTOA=rlwtoa,CZMEAN=czmean, & !Added
- GLAT=glat,GLON=glon,HTOP=htop,HBOT=hbot,htopr=htopr,hbotr=hbotr,ALBEDO=albedo,CUPPT=cuppt,&
- VEGFRA=vegfra,SNOW=snow,G=g,GMT=gmt, & !Modified
- NSTEPRA=stepra,NPHS=nphs,itimestep=itimestep, & !Modified
- julyr=julyr,julday=julday,gfdl_lw=gfdl_lw,gfdl_sw=gfdl_sw, &
- CFRACL=cfracl,CFRACM=cfracm,CFRACH=cfrach, & !Added
- ACFRST=acfrst,NCFRST=ncfrst,ACFRCV=acfrcv,NCFRCV=ncfrcv, & !Added
- ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde, &
- ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme, &
- its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte )
-
-
-#endif
-
- CASE (CAMLWSCHEME)
-
- CALL wrf_debug(100, 'CALL camrad lw')
-
- IF ( PRESENT( OZMIXM ) .AND. PRESENT( PIN ) .AND. &
- PRESENT(M_PS_1) .AND. PRESENT(M_PS_2) .AND. &
- PRESENT(M_HYBI0) .AND. PRESENT(AEROSOLC_1) &
- .AND. PRESENT(AEROSOLC_2).AND. PRESENT(ALSWVISDIR) ) THEN
- CALL CAMRAD(RTHRATENLW=RTHRATEN,RTHRATENSW=RTHRATENSW, &
- RTHRATENLWC=RTHRATENLWC,RTHRATENSWC=RTHRATENSWC, &
- dolw=.true.,dosw=.false., &
- SWUPT=SWUPT,SWUPTC=SWUPTC, &
- SWDNT=SWDNT,SWDNTC=SWDNTC, &
- LWUPT=LWUPT,LWUPTC=LWUPTC, &
- LWDNT=LWDNT,LWDNTC=LWDNTC, &
- SWUPB=SWUPB,SWUPBC=SWUPBC, &
- SWDNB=SWDNB,SWDNBC=SWDNBC, &
- LWUPB=LWUPB,LWUPBC=LWUPBC, &
- LWDNB=LWDNB,LWDNBC=LWDNBC, &
- SWCF=SWCF,LWCF=LWCF,OLR=RLWTOA,CEMISS=CEMISS, &
- TAUCLDC=TAUCLDC,TAUCLDI=TAUCLDI,COSZR=COSZR, &
- GSW=GSW,GLW=GLW,XLAT=XLAT,XLONG=XLONG, &
- ALBEDO=ALBEDO,t_phy=t,TSK=TSK,EMISS=EMISS &
- ,QV3D=qv &
- ,QC3D=qc &
- ,QR3D=qr &
- ,QI3D=qi &
- ,QS3D=qs &
- ,QG3D=qg &
- ,ALSWVISDIR=alswvisdir ,ALSWVISDIF=alswvisdif & !fds ssib alb comp (06/2010)
- ,ALSWNIRDIR=alswnirdir ,ALSWNIRDIF=alswnirdif & !fds ssib alb comp (06/2010)
- ,SWVISDIR=swvisdir ,SWVISDIF=swvisdif & !fds ssib swr comp (06/2010)
- ,SWNIRDIR=swnirdir ,SWNIRDIF=swnirdif & !fds ssib swr comp (06/2010)
- ,SF_SURFACE_PHYSICS=sf_surface_physics & !fds
- ,SWDDIR=swddir,SWDDIF=swddif,SWDDNI=swddni & !amontornes-bcodina (2014-04-20)
- ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr &
- ,F_QI=f_qi,F_QS=f_qs,F_QG=f_qg &
- ,f_ice_phy=f_ice_phy,f_rain_phy=f_rain_phy &
- ,p_phy=p,p8w=p8w,z=z,pi_phy=pi,rho_phy=rho, &
- dz8w=dz8w, &
- CLDFRA=CLDFRA,XLAND=XLAND,XICE=XICE,SNOW=SNOW, &
- ozmixm=ozmixm,pin0=pin,levsiz=levsiz, &
- num_months=n_ozmixm, &
- m_psp=m_ps_1,m_psn=m_ps_2,aerosolcp=aerosolc_1, &
- aerosolcn=aerosolc_2,m_hybi0=m_hybi0, &
- paerlev=paerlev, naer_c=n_aerosolc, &
- cam_abs_dim1=cam_abs_dim1, cam_abs_dim2=cam_abs_dim2, &
- GMT=GMT,JULDAY=JULDAY,JULIAN=JULIAN,YR=YR,DT=DT,XTIME=XTIME,DECLIN=DECLIN, &
- SOLCON=SOLCON,RADT=RADT,DEGRAD=DEGRAD,n_cldadv=3 &
- ,abstot_3d=abstot,absnxt_3d=absnxt,emstot_3d=emstot &
- ,doabsems=doabsems &
- ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &
- ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
- ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte &
- ,coszen=coszen )
- ELSE
- CALL wrf_error_fatal ( 'arguments not present for calling cam radiation' )
- ENDIF
-
- CASE (RRTMG_LWSCHEME)
-
- CALL wrf_debug (100, 'CALL rrtmg_lw')
-
- !Need to reset NLAYERS if vertical nesting is used.
- !This code follows that for case RRTMSCHEME within
- !subroutine RRTMLWRAD.
- IF ( PRESENT(p_top) ) THEN
- p_top_dummy = p_top
- ELSE
- p_top_dummy = -1. ! not used by NMM
- END IF
- IF ( p_top_dummy .GT. 0 ) THEN ! flag value for NMM = -1
- !NLAYERS is recalculated
- !every time the radiation scheme is called. This is
- !necessary if e_vert parent .NE. e_vert nest since
- !NLAYERS could then be different for each domain.
- CALL RRTMG_LWINIT( &
- p_top, .FALSE. , &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- ENDIF
-
- CALL RRTMG_LWRAD( &
- RTHRATENLW=RTHRATEN, &
- RTHRATENLWC=RTHRATENLWC, &
- LWUPT=LWUPT,LWUPTC=LWUPTC,LWUPTCLN=LWUPTCLN, &
- LWDNT=LWDNT,LWDNTC=LWDNTC,LWDNTCLN=LWDNTCLN, &
- LWUPB=LWUPB,LWUPBC=LWUPBC,LWUPBCLN=LWUPBCLN, &
- LWDNB=LWDNB,LWDNBC=LWDNBC,LWDNBCLN=LWDNBCLN, &
- GLW=GLW,OLR=RLWTOA,LWCF=LWCF, &
- EMISS=EMISS, &
- P8W=p8w,P3D=p,PI3D=pi,DZ8W=dz8w,TSK=tsk,T3D=t, &
- T8W=t8w,RHO3D=rho,R=R_d,G=G, &
- ICLOUD=icloud,WARM_RAIN=warm_rain,CLDFRA3D=CLDFRA,&
- cldovrlp=cldovrlp, & ! J. Henderson AER: cldovrlp namelist value
-#if (EM_CORE == 1)
- LRADIUS=lradius, IRADIUS=iradius, &
-#endif
- IS_CAMMGMP_USED=is_cammgmp_used, &
-
-!ckay
-! CLDFRA_KF3D=cldfra_KF,QC_KF3D=qc_KF,QI_KF3D=qi_KF,&
- F_ICE_PHY=F_ICE_PHY,F_RAIN_PHY=F_RAIN_PHY, &
- XLAND=XLAND,XICE=XICE,SNOW=SNOW, &
- QV3D=QV,QC3D=QC,QR3D=QR, &
- QI3D=QI,QS3D=QS,QG3D=QG, &
- O3INPUT=O3INPUT,O33D=O3RAD, &
- F_QV=F_QV,F_QC=F_QC,F_QR=F_QR, &
- F_QI=F_QI,F_QS=F_QS,F_QG=F_QG, &
- RE_CLOUD=re_cloud,RE_ICE=re_ice,RE_SNOW=re_snow, & ! G. Thompson
- has_reqc=has_reqc,has_reqi=has_reqi,has_reqs=has_reqs, & ! G. Thompson
-#if ( WRF_CHEM == 1 )
- TAUAERLW1=tauaerlw1,TAUAERLW2=tauaerlw2, & ! jcb
- TAUAERLW3=tauaerlw3,TAUAERLW4=tauaerlw4, & ! jcb
- TAUAERLW5=tauaerlw5,TAUAERLW6=tauaerlw6, & ! jcb
- TAUAERLW7=tauaerlw7,TAUAERLW8=tauaerlw8, & ! jcb
- TAUAERLW9=tauaerlw9,TAUAERLW10=tauaerlw10, & ! jcb
- TAUAERLW11=tauaerlw11,TAUAERLW12=tauaerlw12, & ! jcb
- TAUAERLW13=tauaerlw13,TAUAERLW14=tauaerlw14, & ! jcb
- TAUAERLW15=tauaerlw15,TAUAERLW16=tauaerlw16, & ! jcb
- aer_ra_feedback=aer_ra_feedback, &
-!jdfcz progn=progn,prescribe=prescribe, &
- progn=progn, &
-#endif
- calc_clean_atm_diag=calc_clean_atm_diag, &
- QNDROP3D=qndrop,F_QNDROP=f_qndrop, &
-!ccc Added for time-varying trace gases.
- YR=YR,JULIAN=JULIAN, &
-!ccc
- IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde,&
- IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme,&
- ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte,&
- LWUPFLX=LWUPFLX,LWUPFLXC=LWUPFLXC, &
- LWDNFLX=LWDNFLX,LWDNFLXC=LWDNFLXC, &
- mp_physics=mp_physics )
-
-
-#if( BUILD_RRTMK == 1)
- CASE (RRTMK_LWSCHEME)
-
- IF ( PRESENT(F_QNC) .AND. PRESENT(QNC_CURR) ) THEN
- call rad_rrtmg_driver( &
- RTHRATEN, RTHRATENSW, &
- RTHRATENLWC, RTHRATENSWC, &
- lwupflx, lwupflxc, lwdnflx, lwdnflxc, &
- swupflx, swupflxc, swdnflx, swdnflxc, &
- lwupt, lwuptc, lwdnt, lwdntc, &
- lwupb, lwupbc, lwdnb, lwdnbc, &
- glw, olr, lwcf, &
- swupt, swuptc, swdnt, swdntc, &
- swupb, swupbc, swdnb, swdnbc, &
- gsw, swcf, &
- coszen, solcon, albedo, emiss, &
- t,t8w, tsk, rho, p, p8w, cldfra, &
- r_d, g, qnc_curr, xland, &
- f_qnc, f_qv, f_qc, f_qr, f_qi, &
- f_qs, f_qg, &
- qv, qc, qr, qi, qs, qg, &
- o3input, o3rad, &
- aer_opt, aerod, no_src_types, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte)
- ELSE
- call wrf_error_fatal('Can not call RRTMG-K. Missing QNC field.')
- ENDIF
-#endif
-
-
-#if( BUILD_RRTMG_FAST == 1)
- CASE (RRTMG_LWSCHEME_FAST)
- CALL wrf_debug (100, 'CALL rrtmg_lw')
-
- CALL RRTMG_LWRAD_FAST( &
- RTHRATENLW=RTHRATEN, &
- RTHRATENLWC=RTHRATENLWC, &
- LWUPT=LWUPT,LWUPTC=LWUPTC, &
- LWDNT=LWDNT,LWDNTC=LWDNTC, &
- LWUPB=LWUPB,LWUPBC=LWUPBC, &
- LWDNB=LWDNB,LWDNBC=LWDNBC, &
- GLW=GLW,OLR=RLWTOA,LWCF=LWCF, &
- EMISS=EMISS, &
- P8W=p8w,P3D=p,PI3D=pi,DZ8W=dz8w,TSK=tsk,T3D=t, &
- T8W=t8w,RHO3D=rho,R=R_d,G=G, &
- ICLOUD=icloud,WARM_RAIN=warm_rain,CLDFRA3D=CLDFRA,&
-#if (EM_CORE == 1)
- LRADIUS=lradius, IRADIUS=iradius, &
-#endif
- IS_CAMMGMP_USED=is_cammgmp_used, &
-
-!ckay
-! CLDFRA_KF3D=cldfra_KF,QC_KF3D=qc_KF,QI_KF3D=qi_KF,&
- F_ICE_PHY=F_ICE_PHY,F_RAIN_PHY=F_RAIN_PHY, &
- XLAND=XLAND,XICE=XICE,SNOW=SNOW, &
- QV3D=QV,QC3D=QC,QR3D=QR, &
- QI3D=QI,QS3D=QS,QG3D=QG, &
- O3INPUT=O3INPUT,O33D=O3RAD, &
- F_QV=F_QV,F_QC=F_QC,F_QR=F_QR, &
- F_QI=F_QI,F_QS=F_QS,F_QG=F_QG, &
- RE_CLOUD=re_cloud,RE_ICE=re_ice,RE_SNOW=re_snow, & ! G. Thompson
- has_reqc=has_reqc,has_reqi=has_reqi,has_reqs=has_reqs, & ! G. Thompson
-#if ( WRF_CHEM == 1 )
- TAUAERLW1=tauaerlw1,TAUAERLW2=tauaerlw2, & ! jcb
- TAUAERLW3=tauaerlw3,TAUAERLW4=tauaerlw4, & ! jcb
- TAUAERLW5=tauaerlw5,TAUAERLW6=tauaerlw6, & ! jcb
- TAUAERLW7=tauaerlw7,TAUAERLW8=tauaerlw8, & ! jcb
- TAUAERLW9=tauaerlw9,TAUAERLW10=tauaerlw10, & ! jcb
- TAUAERLW11=tauaerlw11,TAUAERLW12=tauaerlw12, & ! jcb
- TAUAERLW13=tauaerlw13,TAUAERLW14=tauaerlw14, & ! jcb
- TAUAERLW15=tauaerlw15,TAUAERLW16=tauaerlw16, & ! jcb
- aer_ra_feedback=aer_ra_feedback, &
-!jdfcz progn=progn,prescribe=prescribe, &
- progn=progn, &
-#endif
- QNDROP3D=qndrop,F_QNDROP=f_qndrop, &
-!ccc Added for time-varying trace gases.
- YR=YR,JULIAN=JULIAN, &
-!ccc
- IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde,&
- IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme,&
- ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte,&
- LWUPFLX=LWUPFLX,LWUPFLXC=LWUPFLXC, &
- LWDNFLX=LWDNFLX,LWDNFLXC=LWDNFLXC &
- )
-
-#endif
-
- CASE (HELDSUAREZ)
- CALL wrf_debug (100, 'CALL heldsuarez')
-
- CALL HSRAD(RTHRATEN,p8w,p,pi,dz8w,t, &
- t8w, rho, R_d,G,CP, dt, xlat, degrad, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte )
-
-! -- add by Jin Kong 10/2011
- CASE (FLGLWSCHEME)
- CALL wrf_debug (100, 'CALL Fu-Liou-Gu')
- flg_lw = .true.
-!test Jin Kong 11/01/2011 for ozone
- ozflg = 0.
-!test over
- CALL RAD_FLG( &
- peven=p8w,podd=p,t8w=t8w,degrees=t &
- ,pi3d=pi,o3=ozflg &
- ,G=G,CP=CP &
- ,albedo=ALBEDO,tskin=tsk &
- ,h2o=QV,cld_iccld=QI,cld_wlcld=QC &
- ,cld_prwc=QR,cld_pgwc=QG,cld_snow=QS &
- ,F_QV=F_QV,F_QC=F_QC,F_QR=F_QR &
- ,F_QI=F_QI,F_QS=F_QS,F_QG=F_QG &
- ,warm_rain=warm_rain &
- ,cloudstrf=CLDFRA &
- ,emiss=EMISS &
- ,air_den=rho &
- ,dz3d=dz8w &
- ,SOLCON=SOLCON &
- ,declin=DECLIN &
- ,xtime=xtime, xlong=xlong, xlat=xlat &
- ,JULDAY=JULDAY &
- ,gmt=gmt, radt=radt, degrad=degrad &
- ,dtcolumn=dt &
- ,ids=ids,ide=ide,jds=jds,jde=jde &
- ,kds=kds,kde=kde &
- ,ims=ims,idim=ime,jms=jms,jdim=jme &
- ,kms=kms,kmax=kme &
- ,its=its,ite=ite,jts=jts,jte=jte &
- ,kts=kts,kte=kte &
- ,uswtop=RSWTOA,ulwtop=RLWTOA &
- ,NETSWBOT=GSW,DLWBOT=GLW &
- ,DSWBOT=SWDOWN,deltat=RTHRATEN &
- ,dtshort=RTHRATENSW,dtlongwv=RTHRATENLW &
- ,SWDDIR=swddir,SWDDIF=swddif,SWDDNI=swddni &
- )
-
- CALL wrf_debug(100, 'a4 Fu_Liou-Gu')
-! -- end
-
- CASE DEFAULT
-
- WRITE( wrf_err_message , * ) 'The longwave option does not exist: lw_physics = ', lw_physics
- CALL wrf_error_fatal ( wrf_err_message )
-
- END SELECT lwrad_select
-
- IF (lw_physics .gt. 0 .and. .not.gfdl_lw .and. .not.flg_lw) THEN
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- RTHRATENLW(I,K,J)=RTHRATEN(I,K,J)
-! OLR ALSO WILL CONTAIN OUTGOING LONGWAVE FOR RRTM (NMM HAS NO OLR ARRAY)
- IF(PRESENT(OLR) .AND. K .EQ. 1)OLR(I,J)=RLWTOA(I,J)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
-!NUWRF JJS 20090623 vvvvv
- IF (lw_physics .eq. goddardlwscheme) THEN
- IF ( PRESENT (tlwdn) ) THEN
- DO j=jts,jte
- DO i=its,ite
- tlwdn(i,j) = erbe_out(i,j,1) ! TOA LW downwelling flux [W/m2]
- tlwup(i,j) = erbe_out(i,j,2) ! TOA LW upwelling flux [W/m2]
- slwdn(i,j) = erbe_out(i,j,3) ! surface LW downwelling flux [W/m2]
- slwup(i,j) = erbe_out(i,j,4) ! surface LW upwelling flux [W/m2]
- olr(i,j) = -erbe_out(i,j,2)
- ENDDO
- ENDDO
- ENDIF
- ENDIF
-!NUWRF JJS 20090623 ^^^^^
-
- IF ( PRESENT( AOD5502D ) ) THEN
- ! jararias, 2013/11
- IF ( aer_opt .EQ. 2 ) THEN
- swrad_aerosol_select2: select case(sw_physics)
-
- case(RRTMG_SWSCHEME &
-#if( BUILD_RRTMG_FAST == 1)
- ,RRTMG_SWSCHEME_FAST &
-#endif
-#if( BUILD_RRTMK == 1)
- ,RRTMK_SWSCHEME &
-#endif
- )
- call wrf_debug(100, 'call calc_aerosol_rrtmg_sw')
- call calc_aerosol_rrtmg_sw(ht,dz8w,p,t,qv,aer_type,aer_aod550_opt,aer_angexp_opt, &
- aer_ssa_opt,aer_asy_opt,aer_aod550_val,aer_angexp_val, &
- aer_ssa_val,aer_asy_val,aod5502d,angexp2d,aerssa2d, &
- aerasy2d,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte, &
- tauaer_sw,ssaaer_sw,asyaer_sw )
- do j=jts,jte
- do i=its,ite
- do k=kts,kte
- aod5503d(i,k,j)=tauaer_sw(i,k,j,10) ! band at 550 nm
- end do
- end do
- end do
-
- case default
- end select swrad_aerosol_select2
- ENDIF
- ENDIF
-
- !..Different treatment for aer_opt=3 using QNWFA+QNIFA aerosol species (Trude)
-
- IF (PRESENT(f_qnwfa) .AND. PRESENT(f_qnifa)) THEN
- IF (F_QNWFA .AND. aer_opt.eq.3 .AND. &
- (sw_physics.eq.RRTMG_SWSCHEME &
-#if( BUILD_RRTMG_FAST == 1)
- .OR. sw_physics.eq.RRTMG_SWSCHEME_FAST &
-#endif
-#if( BUILD_RRTMK == 1)
- .OR. sw_physics.eq.RRTMK_SWSCHEME &
-#endif
- )) THEN
- call wrf_debug(100, 'call calc_aerosol_rrtmg_sw with 3D AOD values')
- call calc_aerosol_rrtmg_sw(ht,dz8w,p,t,qv,taer_type,taer_aod550_opt,taer_angexp_opt, &
- taer_ssa_opt,taer_asy_opt,aer_aod550_val,aer_angexp_val, &
- aer_ssa_val,aer_asy_val,taod5502d,angexp2d,aerssa2d, &
- aerasy2d,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte, &
- tauaer_sw,ssaaer_sw,asyaer_sw, taod5503d)
-
- do j=jts,jte
- do i=its,ite
- aod5502d(i,j)= taod5502d(i, j)
- end do
- end do
- ENDIF
- ENDIF
-
- swrad_select: SELECT CASE(sw_physics)
-
- CASE (SWRADSCHEME)
- CALL wrf_debug(100, 'CALL swrad')
- CALL SWRAD( &
- DT=dt,RTHRATEN=rthraten,GSW=gsw &
- ,XLAT=xlat,XLONG=xlong,ALBEDO=albedo &
-#if ( WRF_CHEM == 1 )
- ,PM2_5_DRY=pm2_5_dry,PM2_5_WATER=pm2_5_water &
- ,PM2_5_DRY_EC=pm2_5_dry_ec &
-#endif
- ,RHO_PHY=rho,T3D=t &
- ,P3D=p,PI3D=pi,DZ8W=dz8w,GMT=gmt &
- ,R=r_d,CP=cp,G=g,JULDAY=julday &
- ,XTIME=xtime,DECLIN=declin,SOLCON=solcon &
- ,RADFRQ=radt,ICLOUD=icloud,DEGRAD=degrad &
- ,warm_rain=warm_rain &
- ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &
- ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
- ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte &
- ,QV3D=qv &
- ,QC3D=qc &
- ,QR3D=qr &
- ,QI3D=qi &
- ,QS3D=qs &
- ,QG3D=qg &
- ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr &
- ,F_QI=f_qi,F_QS=f_qs,F_QG=f_qg &
- ,coszen=coszen,julian=julian &
- ,obscur=obscur_loc )
-
- CASE (GSFCSWSCHEME)
- CALL wrf_debug(100, 'CALL gsfcswrad')
- CALL GSFCSWRAD( &
- RTHRATEN=rthraten,GSW=gsw & ! PAJ: xlat and xlong removed.
- ,ALB=albedo,T3D=t,P3D=p,P8W3D=p8w,pi3D=pi &
- ,DZ8W=dz8w,RHO_PHY=rho &
- ,CLDFRA3D=cldfra,RSWTOA=rswtoa &
- ,CP=cp,G=g & ! PAJ: GMT removed.
- ,JULDAY=julday & ! PAJ: XTIME removed.
- ,SOLCON=solcon & ! PAJ: declin removed
-! ,RADFRQ=radt,DEGRAD=degrad & ! PAJ: degrad and radfrq removed
- ,TAUCLDI=taucldi,TAUCLDC=taucldc &
- ,WARM_RAIN=warm_rain &
-
-#if ( WRF_CHEM == 1 )
- ,TAUAER300=tauaer300,TAUAER400=tauaer400 & ! jcb
- ,TAUAER600=tauaer600,TAUAER999=tauaer999 & ! jcb
- ,GAER300=gaer300,GAER400=gaer400 & ! jcb
- ,GAER600=gaer600,GAER999=gaer999 & ! jcb
- ,WAER300=waer300,WAER400=waer400 & ! jcb
- ,WAER600=waer600,WAER999=waer999 & ! jcb
- ,aer_ra_feedback=aer_ra_feedback &
-#endif
- ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &
- ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
- ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte &
- ,QV3D=qv &
- ,QC3D=qc &
- ,QR3D=qr &
- ,QI3D=qi &
- ,QS3D=qs &
- ,QG3D=qg &
- ,QNDROP3D=qndrop &
- ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr &
- ,F_QI=f_qi,F_QS=f_qs,F_QG=f_qg &
- ,F_QNDROP=f_qndrop &
- ,COSZEN=coszen &
- ,OBSCUR=obscur_loc &
- )
-
- case (goddardswscheme)
-
- CALL wrf_debug(100, 'CALL NUWRF goddard shortwave radiation scheme 2017')
-
- IF ( mp_physics .NE. nuwrf4icescheme ) THEN
- IF ( has_reqc .EQ. 1 ) THEN
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- re_cloud_gsfc(i,k,j) = re_cloud(i,k,j) * 1.E+6
- re_ice_gsfc(i,k,j) = re_ice(i,k,j) * 1.E+6
- re_snow_gsfc(i,k,j) = re_snow(i,k,j) * 1.E+6
- re_rain_gsfc(i,k,j) = 0.
- re_graupel_gsfc(i,k,j) = 0.
- re_hail_gsfc(i,k,j) = 0.
- ENDDO
- ENDDO
- ENDDO
- ELSE
- WRITE ( wrf_err_message , * ) 'Must choose a microphysics that provides effective radii.'
- CALL wrf_debug (0, wrf_err_message)
- END IF
- END IF
-
- CALL goddardrad(sw_or_lw='sw',dx=dx &
- ,rthraten=rthraten,gsf=gsw,xlat=xlat,xlong=xlong &
- ,alb=albedo,t3d=t,p3d=p,p8w3d=p8w,pi3d=pi &
- ,dz8w=dz8w,rho_phy=rho,emiss=emiss,tsk=tsk &
- ,cldfra3d=cldfra &
- ,gmt=gmt,cp=cp,g=g,t8w=t8w &
- ,julday=julday,xtime=xtime &
- ,declin=declin,solcon=solcon &
- ,radfrq=radt,degrad=degrad &
- ,warm_rain=warm_rain &
- ,ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde &
- ,ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme &
- ,its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte &
- ,qv=qv,qc=qc,qr=qr,qi=qi,qs=qs,qg=qg,qh=qh & !optional
- ,f_qv=f_qv,f_qc=f_qc,f_qr=f_qr & !optional
- ,f_qi=f_qi,f_qs=f_qs,f_qg=f_qg ,f_qh=f_qh & !optional
- ,rec3d=re_cloud_gsfc,rei3d=re_ice_gsfc & !optional
- ,rer3d=re_rain_gsfc,res3d=re_snow_gsfc & !optional
- ,reg3d=re_graupel_gsfc,reh3d=re_hail_gsfc & !optional
- ,erbe_out=erbe_out &
- ,cod2d_out=cod2d_out,ctop2d_out=ctop2d_out & !optional
- ,sflxd=sflxd & !optional
- ,swddir=swddir,swddni=swddni,swddif=swddif & !optional
- ,coszen=coszen & !optional
- ,obscur=obscur_loc &
- ,itimestep=itimestep, dt_in = dt &
-#if (WRF_CHEM == 1)
- ,aod2d_out=aod2d_out, atop2d_out=atop2d_out & ! optional
- ,AERO=aero &
- ,CHEM_OPT=chem_opt &
- ,GSFCRAD_GOCART_COUPLING=gsfcrad_gocart_coupling &
-#endif
- )
-
- CASE (CAMSWSCHEME)
- CALL wrf_debug(100, 'CALL camrad sw')
- IF ( PRESENT( OZMIXM ) .AND. PRESENT( PIN ) .AND. &
- PRESENT(M_PS_1) .AND. PRESENT(M_PS_2) .AND. &
- PRESENT(M_HYBI0) .AND. PRESENT(AEROSOLC_1) &
- .AND. PRESENT(AEROSOLC_2) .AND. PRESENT(ALSWVISDIR)) THEN
- CALL CAMRAD(RTHRATENLW=RTHRATEN,RTHRATENSW=RTHRATENSW, &
- RTHRATENLWC=RTHRATENLWC,RTHRATENSWC=RTHRATENSWC, &
- dolw=.false.,dosw=.true., &
- SWUPT=SWUPT,SWUPTC=SWUPTC, &
- SWDNT=SWDNT,SWDNTC=SWDNTC, &
- LWUPT=LWUPT,LWUPTC=LWUPTC, &
- LWDNT=LWDNT,LWDNTC=LWDNTC, &
- SWUPB=SWUPB,SWUPBC=SWUPBC, &
- SWDNB=SWDNB,SWDNBC=SWDNBC, &
- LWUPB=LWUPB,LWUPBC=LWUPBC, &
- LWDNB=LWDNB,LWDNBC=LWDNBC, &
- SWCF=SWCF,LWCF=LWCF,OLR=RLWTOA,CEMISS=CEMISS, &
- TAUCLDC=TAUCLDC,TAUCLDI=TAUCLDI,COSZR=COSZR, &
- GSW=GSW,GLW=GLW,XLAT=XLAT,XLONG=XLONG, &
- ALBEDO=ALBEDO,t_phy=t,TSK=TSK,EMISS=EMISS &
- ,QV3D=qv &
- ,QC3D=qc &
- ,QR3D=qr &
- ,QI3D=qi &
- ,QS3D=qs &
- ,QG3D=qg &
- ,ALSWVISDIR=alswvisdir ,ALSWVISDIF=alswvisdif & !fds ssib alb comp (06/2010)
- ,ALSWNIRDIR=alswnirdir ,ALSWNIRDIF=alswnirdif & !fds ssib alb comp (06/2010)
- ,SWVISDIR=swvisdir ,SWVISDIF=swvisdif & !fds ssib swr comp (06/2010)
- ,SWNIRDIR=swnirdir ,SWNIRDIF=swnirdif & !fds ssib swr comp (06/2010)
- ,SF_SURFACE_PHYSICS=sf_surface_physics & !fds
- ,SWDDIR=swddir,SWDDIF=swddif,SWDDNI=swddni & !amontornes-bcodina (2014-04-20)
- ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr &
- ,F_QI=f_qi,F_QS=f_qs,F_QG=f_qg &
- ,f_ice_phy=f_ice_phy,f_rain_phy=f_rain_phy &
- ,p_phy=p,p8w=p8w,z=z,pi_phy=pi,rho_phy=rho, &
- dz8w=dz8w, &
- CLDFRA=CLDFRA,XLAND=XLAND,XICE=XICE,SNOW=SNOW, &
- ozmixm=ozmixm,pin0=pin,levsiz=levsiz, &
- num_months=n_ozmixm, &
- m_psp=m_ps_1,m_psn=m_ps_2,aerosolcp=aerosolc_1, &
- aerosolcn=aerosolc_2,m_hybi0=m_hybi0, &
- paerlev=paerlev, naer_c=n_aerosolc, &
- cam_abs_dim1=cam_abs_dim1, cam_abs_dim2=cam_abs_dim2, &
- GMT=GMT,JULDAY=JULDAY,JULIAN=JULIAN,YR=YR,DT=DT,XTIME=XTIME,DECLIN=DECLIN, &
- SOLCON=SOLCON,RADT=RADT,DEGRAD=DEGRAD,n_cldadv=3 &
- ,abstot_3d=abstot,absnxt_3d=absnxt,emstot_3d=emstot &
- ,doabsems=doabsems &
- ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &
- ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
- ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte &
- ,coszen=coszen )
- ELSE
- CALL wrf_error_fatal ( 'arguments not present for calling cam radiation' )
- ENDIF
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- RTHRATEN(I,K,J)=RTHRATEN(I,K,J)+RTHRATENSW(I,K,J)
- ENDDO
- ENDDO
- ENDDO
-
- CASE (RRTMG_SWSCHEME)
-
- CALL wrf_debug(100, 'CALL rrtmg_sw')
-
- if ( direct_sw_feedback .and. feedback_is_ready ) then
- proceed_twoway_sw = .true.
-
- if (present(mass_ws_i)) then
-
- mass_ws_i(:,kte+1,:) = mass_ws_i(:,kte,:)
- mass_ws_j(:,kte+1,:) = mass_ws_j(:,kte,:)
- mass_ws_k(:,kte+1,:) = mass_ws_k(:,kte,:)
-
- mass_in_i(:,kte+1,:) = mass_in_i(:,kte,:)
- mass_in_j(:,kte+1,:) = mass_in_j(:,kte,:)
- mass_in_k(:,kte+1,:) = mass_in_k(:,kte,:)
-
- mass_ec_i(:,kte+1,:) = mass_ec_i(:,kte,:)
- mass_ec_j(:,kte+1,:) = mass_ec_j(:,kte,:)
- mass_ec_k(:,kte+1,:) = mass_ec_k(:,kte,:)
-
- mass_ss_i(:,kte+1,:) = mass_ss_i(:,kte,:)
- mass_ss_j(:,kte+1,:) = mass_ss_j(:,kte,:)
- mass_ss_k(:,kte+1,:) = mass_ss_k(:,kte,:)
-
- mass_h2o_i(:,kte+1,:) = mass_h2o_i(:,kte,:)
- mass_h2o_j(:,kte+1,:) = mass_h2o_j(:,kte,:)
- mass_h2o_k(:,kte+1,:) = mass_h2o_k(:,kte,:)
-
- dgn_i(:,kte+1,:) = dgn_i(:,kte,:)
- dgn_j(:,kte+1,:) = dgn_j(:,kte,:)
- dgn_k(:,kte+1,:) = dgn_k(:,kte,:)
-
- sig_i(:,kte+1,:) = sig_i(:,kte,:)
- sig_j(:,kte+1,:) = sig_j(:,kte,:)
- sig_k(:,kte+1,:) = sig_k(:,kte,:)
- end if
- else
- proceed_twoway_sw = .false.
- end if
-
- CALL RRTMG_SWRAD( &
- RTHRATENSW=RTHRATENSW, &
- RTHRATENSWC=RTHRATENSWC, &
- SWUPT=SWUPT,SWUPTC=SWUPTC,SWUPTCLN=SWUPTCLN, &
- SWDNT=SWDNT,SWDNTC=SWDNTC,SWDNTCLN=SWDNTCLN, &
- SWUPB=SWUPB,SWUPBC=SWUPBC,SWUPBCLN=SWUPBCLN, &
- SWDNB=SWDNB,SWDNBC=SWDNBC,SWDNBCLN=SWDNBCLN, &
- SWCF=SWCF,GSW=GSW, &
- XTIME=XTIME,GMT=GMT,XLAT=XLAT,XLONG=XLONG, &
- RADT=RADT,DEGRAD=DEGRAD,DECLIN=DECLIN, &
- COSZR=COSZR,JULDAY=JULDAY,SOLCON=SOLCON, &
- ALBEDO=ALBEDO,t3d=t,t8w=t8w,TSK=TSK, &
- p3d=p,p8w=p8w,pi3d=pi,rho3d=rho, &
- dz8w=dz8w,CLDFRA3D=CLDFRA, &
-#if (EM_CORE == 1)
- LRADIUS=lradius, IRADIUS=iradius, &
-#endif
- IS_CAMMGMP_USED=is_cammgmp_used, &
- R=R_D,G=G, &
-!ckay
-! CLDFRA_KF3D=cldfra_KF,QC_KF3D=qc_KF,QI_KF3D=qi_KF,&
- ICLOUD=icloud,WARM_RAIN=warm_rain, &
- cldovrlp=cldovrlp, & ! J. Henderson AER: cldovrlp namelist value
- F_ICE_PHY=F_ICE_PHY,F_RAIN_PHY=F_RAIN_PHY, &
- XLAND=XLAND,XICE=XICE,SNOW=SNOW, &
- QV3D=qv,QC3D=qc,QR3D=qr, &
- QI3D=qi,QS3D=qs,QG3D=qg, &
- O3INPUT=O3INPUT,O33D=O3RAD, &
- AER_OPT=AER_OPT,aerod=aerod,no_src=no_src_types, &
- ALSWVISDIR=alswvisdir ,ALSWVISDIF=alswvisdif, & !Zhenxin ssib alb comp (06/2010)
- ALSWNIRDIR=alswnirdir ,ALSWNIRDIF=alswnirdif, & !Zhenxin ssib alb comp (06/2010)
- SWVISDIR=swvisdir ,SWVISDIF=swvisdif, & !Zhenxin ssib swr comp (06/2010)
- SWNIRDIR=swnirdir ,SWNIRDIF=swnirdif, & !Zhenxin ssib swr comp (06/2010)
- SF_SURFACE_PHYSICS=sf_surface_physics, & !Zhenxin ssib sw_phy (06/2010)
- F_QV=f_qv,F_QC=f_qc,F_QR=f_qr, &
- F_QI=f_qi,F_QS=f_qs,F_QG=f_qg, &
- RE_CLOUD=re_cloud,RE_ICE=re_ice,RE_SNOW=re_snow, & ! G. Thompson
- has_reqc=has_reqc,has_reqi=has_reqi,has_reqs=has_reqs, & ! G. Thompson
-#if ( WRF_CHEM == 1 )
- TAUAER300=tauaer300,TAUAER400=tauaer400, & ! jcb
- TAUAER600=tauaer600,TAUAER999=tauaer999, & ! jcb
- GAER300=gaer300,GAER400=gaer400, & ! jcb
- GAER600=gaer600,GAER999=gaer999, & ! jcb
- WAER300=waer300,WAER400=waer400, & ! jcb
- WAER600=waer600,WAER999=waer999, & ! jcb
- aer_ra_feedback=aer_ra_feedback, &
-!jdfcz progn=progn,prescribe=prescribe, &
- progn=progn, &
-#endif
- calc_clean_atm_diag=calc_clean_atm_diag, &
- QNDROP3D=qndrop,F_QNDROP=f_qndrop, &
- IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde,&
- IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme,&
- ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte,&
- SWUPFLX=SWUPFLX,SWUPFLXC=SWUPFLXC, &
- SWDNFLX=SWDNFLX,SWDNFLXC=SWDNFLXC, &
- tauaer3d_sw=tauaer_sw, & ! jararias 2013/11
- ssaaer3d_sw=ssaaer_sw, & ! jararias 2013/11
- asyaer3d_sw=asyaer_sw, & ! jararias 2013/11
- swddir=swddir,swddni=swddni,swddif=swddif, & ! jararias 2013/08/10
- swdownc=swdownc, swddnic=swddnic, swddirc=swddirc, & ! PAJ
- obscur=obscur_loc, &
- xcoszen=coszen,yr=yr,julian=julian,mp_physics=mp_physics, & ! jararias 2013/08/14
- proceed_twoway_sw=proceed_twoway_sw, & ! WRF-CMAQ coupled model
- nmode=3, & ! WRF-CMAQ coupled model
- mass_ws_i=mass_ws_i, & ! WRF-CMAQ coupled model
- mass_ws_j=mass_ws_j, & ! WRF-CMAQ coupled model
- mass_ws_k=mass_ws_k, & ! WRF-CMAQ coupled model
- mass_in_i=mass_in_i, & ! WRF-CMAQ coupled model
- mass_in_j=mass_in_j, & ! WRF-CMAQ coupled model
- mass_in_k=mass_in_k, & ! WRF-CMAQ coupled model
- mass_ec_i=mass_ec_i, & ! WRF-CMAQ coupled model
- mass_ec_j=mass_ec_j, & ! WRF-CMAQ coupled model
- mass_ec_k=mass_ec_k, & ! WRF-CMAQ coupled model
- mass_ss_i=mass_ss_i, & ! WRF-CMAQ coupled model
- mass_ss_j=mass_ss_j, & ! WRF-CMAQ coupled model
- mass_ss_k=mass_ss_k, & ! WRF-CMAQ coupled model
- mass_h2o_i=mass_h2o_i, & ! WRF-CMAQ coupled model
- mass_h2o_j=mass_h2o_j, & ! WRF-CMAQ coupled model
- mass_h2o_k=mass_h2o_k, & ! WRF-CMAQ coupled model
- dgn_i=dgn_i, & ! WRF-CMAQ coupled model
- dgn_j=dgn_j, & ! WRF-CMAQ coupled model
- dgn_k=dgn_k, & ! WRF-CMAQ coupled model
- sig_i=sig_i, & ! WRF-CMAQ coupled model
- sig_j=sig_j, & ! WRF-CMAQ coupled model
- sig_k=sig_k, & ! WRF-CMAQ coupled model
- gtauxar_01=sw_gtauxar_01, & ! WRF-CMAQ coupled model
- gtauxar_02=sw_gtauxar_02, & ! WRF-CMAQ coupled model
- gtauxar_03=sw_gtauxar_03, & ! WRF-CMAQ coupled model
- gtauxar_04=sw_gtauxar_04, & ! WRF-CMAQ coupled model
- gtauxar_05=sw_gtauxar_05, & ! WRF-CMAQ coupled model
- asy_fac_01=sw_asy_fac_01, & ! WRF-CMAQ coupled model
- asy_fac_02=sw_asy_fac_02, & ! WRF-CMAQ coupled model
- asy_fac_03=sw_asy_fac_03, & ! WRF-CMAQ coupled model
- asy_fac_04=sw_asy_fac_04, & ! WRF-CMAQ coupled model
- asy_fac_05=sw_asy_fac_05, & ! WRF-CMAQ coupled model
- ssa_01=sw_ssa_01, & ! WRF-CMAQ coupled model
- ssa_02=sw_ssa_02, & ! WRF-CMAQ coupled model
- ssa_03=sw_ssa_03, & ! WRF-CMAQ coupled model
- ssa_04=sw_ssa_04, & ! WRF-CMAQ coupled model
- ssa_05=sw_ssa_05, & ! WRF-CMAQ coupled model
- sw_zbbcddir=sw_zbbcddir, & ! WRF-CMAQ coupled model
- sw_dirdflux=sw_dirdflux, & ! WRF-CMAQ coupled model
- sw_difdflux=sw_difdflux & ! WRF-CMAQ coupled model
- )
-
- ! = WRF-CMAQ twoway coupled model
- if (proceed_twoway_sw) then
- DO j=jts,jte
- DO i=its,ite
- sw_ttauxar_01(i,j) = sum(sw_gtauxar_01(i,:,j))
- sw_ttauxar_02(i,j) = sum(sw_gtauxar_02(i,:,j))
- sw_ttauxar_03(i,j) = sum(sw_gtauxar_03(i,:,j))
- sw_ttauxar_04(i,j) = sum(sw_gtauxar_04(i,:,j))
- sw_ttauxar_05(i,j) = sum(sw_gtauxar_05(i,:,j))
- END DO
- END DO
- end if
-
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- RTHRATEN(I,K,J)=RTHRATEN(I,K,J)+RTHRATENSW(I,K,J)
- ENDDO
- ENDDO
- ENDDO
-
-#if( BUILD_RRTMK == 1)
- CASE (RRTMK_SWSCHEME)
-
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- RTHRATEN(I,K,J)=RTHRATEN(I,K,J)+RTHRATENSW(I,K,J)
- ENDDO
- ENDDO
- ENDDO
-#endif
-
-#if( BUILD_RRTMG_FAST == 1)
- CASE (RRTMG_SWSCHEME_FAST)
- CALL wrf_debug(100, 'CALL rrtmg_sw_fast')
- CALL RRTMG_SWRAD_FAST( &
- RTHRATENSW=RTHRATENSW, &
- RTHRATENSWC=RTHRATENSWC, &
- SWUPT=SWUPT,SWUPTC=SWUPTC, &
- SWDNT=SWDNT,SWDNTC=SWDNTC, &
- SWUPB=SWUPB,SWUPBC=SWUPBC, &
- SWDNB=SWDNB,SWDNBC=SWDNBC, &
- SWCF=SWCF,GSW=GSW, &
- XTIME=XTIME,GMT=GMT,XLAT=XLAT,XLONG=XLONG, &
- RADT=RADT,DEGRAD=DEGRAD,DECLIN=DECLIN, &
- COSZR=COSZR,JULDAY=JULDAY,SOLCON=SOLCON, &
- ALBEDO=ALBEDO,t3d=t,t8w=t8w,TSK=TSK, &
- p3d=p,p8w=p8w,pi3d=pi,rho3d=rho, &
- dz8w=dz8w,CLDFRA3D=CLDFRA, &
-#if (EM_CORE == 1)
- LRADIUS=lradius, IRADIUS=iradius, &
-#endif
- IS_CAMMGMP_USED=is_cammgmp_used, &
- R=R_D,G=G, &
-!ckay
-! CLDFRA_KF3D=cldfra_KF,QC_KF3D=qc_KF,QI_KF3D=qi_KF,&
- ICLOUD=icloud,WARM_RAIN=warm_rain, &
- F_ICE_PHY=F_ICE_PHY,F_RAIN_PHY=F_RAIN_PHY, &
- XLAND=XLAND,XICE=XICE,SNOW=SNOW, &
- QV3D=qv,QC3D=qc,QR3D=qr, &
- QI3D=qi,QS3D=qs,QG3D=qg, &
- O3INPUT=O3INPUT,O33D=O3RAD, &
- AER_OPT=AER_OPT,aerod=aerod,no_src=no_src_types, &
- ALSWVISDIR=alswvisdir ,ALSWVISDIF=alswvisdif, & !Zhenxin ssib alb comp (06/2010)
- ALSWNIRDIR=alswnirdir ,ALSWNIRDIF=alswnirdif, & !Zhenxin ssib alb comp (06/2010)
- SWVISDIR=swvisdir ,SWVISDIF=swvisdif, & !Zhenxin ssib swr comp (06/2010)
- SWNIRDIR=swnirdir ,SWNIRDIF=swnirdif, & !Zhenxin ssib swr comp (06/2010)
- SF_SURFACE_PHYSICS=sf_surface_physics, & !Zhenxin ssib sw_phy (06/2010)
- F_QV=f_qv,F_QC=f_qc,F_QR=f_qr, &
- F_QI=f_qi,F_QS=f_qs,F_QG=f_qg, &
- RE_CLOUD=re_cloud,RE_ICE=re_ice,RE_SNOW=re_snow, & ! G. Thompson
- has_reqc=has_reqc,has_reqi=has_reqi,has_reqs=has_reqs, & ! G. Thompson
-#if ( WRF_CHEM == 1 )
- TAUAER300=tauaer300,TAUAER400=tauaer400, & ! jcb
- TAUAER600=tauaer600,TAUAER999=tauaer999, & ! jcb
- GAER300=gaer300,GAER400=gaer400, & ! jcb
- GAER600=gaer600,GAER999=gaer999, & ! jcb
- WAER300=waer300,WAER400=waer400, & ! jcb
- WAER600=waer600,WAER999=waer999, & ! jcb
- aer_ra_feedback=aer_ra_feedback, &
-!jdfcz progn=progn,prescribe=prescribe, &
- progn=progn, &
-#endif
- QNDROP3D=qndrop,F_QNDROP=f_qndrop, &
- IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde,&
- IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme,&
- ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte,&
- SWUPFLX=SWUPFLX,SWUPFLXC=SWUPFLXC, &
- SWDNFLX=SWDNFLX,SWDNFLXC=SWDNFLXC, &
- tauaer3d_sw=tauaer_sw, & ! jararias 2013/11
- ssaaer3d_sw=ssaaer_sw, & ! jararias 2013/11
- asyaer3d_sw=asyaer_sw, & ! jararias 2013/11
- swddir=swddir,swddni=swddni,swddif=swddif, & ! jararias 2013/08/10
- swdownc=swdownc, swddnic=swddnic, swddirc=swddirc, & ! PAJ
- xcoszen=coszen,yr=yr,julian=julian ) ! jararias 2013/08/14
-
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- RTHRATEN(I,K,J)=RTHRATEN(I,K,J)+RTHRATENSW(I,K,J)
- ENDDO
- ENDDO
- ENDDO
-#endif
-
- CASE (GFDLSWSCHEME)
-
- CALL wrf_debug (100, 'CALL gfdlsw')
-
- IF ( PRESENT(F_QV) .AND. PRESENT(F_QC) .AND. &
- PRESENT(F_QI) .AND. (PRESENT(qi) .OR. PRESENT(qs)) .AND. &
- PRESENT(qv) .AND. PRESENT(qc) ) THEN
- IF ( F_QV .AND. F_QC .AND. (F_QI .OR. F_QS)) THEN
- gfdl_sw = .true.
- CALL ETARA( &
- DT=dt,XLAND=xland &
- ,P8W=p8w,DZ8W=dz8w,RHO_PHY=rho,P_PHY=p,T=t &
- ,QV=qv,QW=qc_temp,QI=qi,QS=qs &
- ,TSK2D=tsk,GLW=GLW,RSWIN=SWDOWN,GSW=GSW &
- ,RSWINC=SWDOWNC,CLDFRA=CLDFRA,PI3D=pi &
- ,GLAT=glat,GLON=glon,HTOP=htop,HBOT=hbot &
- ,HBOTR=hbotr, HTOPR=htopr &
- ,ALBEDO=albedo,CUPPT=cuppt &
- ,VEGFRA=vegfra,SNOW=snow,G=g,GMT=gmt &
- ,NSTEPRA=stepra,NPHS=nphs,ITIMESTEP=itimestep &
- ,XTIME=xtime,JULIAN=julian &
- ,JULYR=julyr,JULDAY=julday &
- ,GFDL_LW=gfdl_lw,GFDL_SW=gfdl_sw &
- ,CFRACL=cfracl,CFRACM=cfracm,CFRACH=cfrach &
- ,ACFRST=acfrst,NCFRST=ncfrst &
- ,ACFRCV=acfrcv,NCFRCV=ncfrcv &
- ,RSWTOA=rswtoa,RLWTOA=rlwtoa,CZMEAN=czmean &
- ,THRATEN=rthraten,THRATENLW=rthratenlw &
- ,THRATENSW=rthratensw &
- ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &
- ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
- ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte &
- )
- ELSE
- CALL wrf_error_fatal('Can not call ETARA (2a). Missing moisture fields.')
- ENDIF
- ELSE
- CALL wrf_error_fatal('Can not call ETARA (2b). Missing moisture fields.')
- ENDIF
-
-#if ( HWRF == 1 )
-
- CASE (HWRFSWSCHEME)
-
- CALL wrf_debug (100, 'CALL hwrfsw')
-
- gfdl_sw = .true.
- CALL HWRFRA(explicit_convection=expl_conv, &
- DT=dt,thraten=RTHRATEN,thratenlw=RTHRATENLW,thratensw=RTHRATENSW,pi3d=pi, &
- XLAND=xland,P8w=p8w,DZ8w=dz8w,RHO_PHY=rho,P_PHY=p,T=t, &
- QV=qv,QW=qc_temp,QI=Qi, &
- TSK2D=tsk,GLW=GLW,GSW=GSW, &
- TOTSWDN=swdown,TOTLWDN=glw,RSWTOA=rswtoa,RLWTOA=rlwtoa,CZMEAN=czmean, & !Added
- GLAT=glat,GLON=glon,HTOP=htop,HBOT=hbot,htopr=htopr,hbotr=hbotr,ALBEDO=albedo,CUPPT=cuppt, &
- VEGFRA=vegfra,SNOW=snow,G=g,GMT=gmt, & !Modified
- NSTEPRA=stepra,NPHS=nphs,itimestep=itimestep, & !Modified
- julyr=julyr,julday=julday,gfdl_lw=gfdl_lw,gfdl_sw=gfdl_sw, &
- CFRACL=cfracl,CFRACM=cfracm,CFRACH=cfrach, & !Added
- ACFRST=acfrst,NCFRST=ncfrst,ACFRCV=acfrcv,NCFRCV=ncfrcv, & !Added
- ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde, &
- ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme, &
- its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte )
-#endif
-
- CASE (0)
-
- ! Here in case we don't want to call a sw radiation scheme
- ! For example, the Held-Suarez idealized test case
- IF (lw_physics /= HELDSUAREZ) THEN
- WRITE( wrf_err_message , * ) &
-'You have selected a longwave radiation option, but not a shortwave option (sw_physics = 0, lw_physics = ',lw_physics,')'
- CALL wrf_error_fatal ( wrf_err_message )
- END IF
-
-! -- add by Jin Kong 10/2011
-!--- the following FLGSWSCHEME is for testing only
- CASE (FLGSWSCHEME)
- flg_sw = .true.
-!--- No need to do anything since the short and long wave is calculted in one program
-! -- end
-
- CASE DEFAULT
-
- WRITE( wrf_err_message , * ) 'The shortwave option does not exist: sw_physics = ', sw_physics
- CALL wrf_error_fatal ( wrf_err_message )
-
- END SELECT swrad_select
-
-!NUWRF JJS 20090623 vvvvv
- IF (sw_physics .eq. goddardswscheme) THEN
- IF ( PRESENT (tswdn) ) THEN
- DO j=jts,jte
- DO i=its,ite
- tswdn(i,j) = erbe_out(i,j,5) ! TOA SW downwelling flux [W/m2]
- tswup(i,j) = erbe_out(i,j,6) ! TOA SW upwelling flux [W/m2]
- sswdn(i,j) = erbe_out(i,j,7) ! surface SW downwelling flux [W/m2]
- sswup(i,j) = erbe_out(i,j,8) ! surface SW upwelling flux [W/m2]
- ENDDO
- ENDDO
- ENDIF
- ENDIF
-!NUWRF JJS 20090623 ^^^^^
-
- IF (sw_physics .gt. 0 .and. .not.gfdl_sw .and. .not.flg_sw) THEN
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- RTHRATENSW(I,K,J)=RTHRATEN(I,K,J)-RTHRATENLW(I,K,J)
- ENDDO
- ENDDO
- ENDDO
-
- DO j=jts,jte
- DO i=its,ite
- SWDOWN(I,J)=GSW(I,J)/(1.-ALBEDO(I,J))
- ENDDO
- ENDDO
- ENDIF
-
-! jararias, 14/08/2013
- ! surface direct and diffuse SW fluxes computation. Only for schemes other than RRTMG and Goddard
- ! Backup method in case sw scheme in use does not provide surface SW direct and diffuse irradiances
- IF ((sw_physics .NE. RRTMG_SWSCHEME) &
-#if( BUILD_RRTMG_FAST == 1)
- .AND. (sw_physics .NE. RRTMG_SWSCHEME_FAST) &
-#endif
- .AND. (sw_physics .NE. FLGSWSCHEME) .AND. (sw_physics .NE. CAMSWSCHEME) & ! amontornes-bcodina (2014-04-20)
-#if( BUILD_RRTMK == 1)
- .AND. (sw_physics .NE. RRTMK_SWSCHEME) &
-#endif
- .AND. (sw_physics .ne. GODDARDSWSCHEME)) THEN
- DO j=jts,jte
- DO i=its,ite
- IF (coszen(i,j).GT.1e-3) THEN
- ioh=solcon*coszen(i,j) ! TOA irradiance
- kt=swdown(i,j)/max(ioh,1e-3) ! clearness index
- ! Optical air mass: Rigollier et al. (2000) doi:
- ! 10.1016/S0038-092X(99)00055-9
- airmass=exp(-ht(i,j)/8434.5)/(coszen(i,j)+ &
- 0.50572*(asin(coszen(i,j))*57.295779513082323+6.07995)**(-1.6364))
- ! kt correction for air-mass at large sza: Perez et al. (1990)
- ! doi: 10.1016/0038-092X(90)90036-C
- kt=kt/(0.1+1.031*exp(-1.4/(0.9+(9.4/max(airmass,1e-3)))))
- ! Diffuse fraction: Ruiz-Arias et al. (2010) (Eq 33) doi:
- ! 10.1016/j.enconman.2009.11.024
- kd=0.952-1.041*exp(-exp(2.300-4.702*kt))
- swddif(i,j)=kd*swdown(i,j)
- swddir(i,j)=(1.-kd)*swdown(i,j)
- swddni(i,j)=swddir(i,j)/max(coszen(i,j),1e-4)
- ENDIF
- ENDDO
- ENDDO
- ENDIF
-
- IF ( PRESENT( diffuse_frac ) ) THEN
- DO j=jts,jte
- DO i=its,ite
- if (swdown(i,j).gt.0.001) then
- diffuse_frac(i,j) = swddif(i,j)/swdown(i,j)
- diffuse_frac(i,j) = min(diffuse_frac(i,j),1.0)
- else
- diffuse_frac(i,j) = 0.
- endif
- ENDDO
- ENDDO
- ENDIF
-
- ! jararias, aug 2013, updated 2013/11
- ! parameters update for SW surface fluxes interpolation
- IF (swint_opt.EQ.1) THEN
- ! interpolation applies on all-sky fluxes (swddir, swdown)
- CALL update_swinterp_parameters(ims,ime,jms,jme,its,ite,jts,jte, &
- coszen,coszen_loc,swddir,swdown, &
- swddir_ref,bb,Bx,swdown_ref,gg,Gx, &
- coszen_ref )
- ENDIF
-
- IF ( PRESENT( obscur ) ) THEN
- IF ( sw_eclipse == eclipsescheme ) THEN
- DO j=jts,jte
- DO i=its,ite
- obscur(i,j) = obscur_loc(i,j)
- mask(i,j) = mask_loc(i,j)
- ENDDO
- ENDDO
- elat_track = elat_loc
- elon_track = elon_loc
- ENDIF
- ENDIF
-
- ENDDO
- !$OMP END PARALLEL DO
-
- IF ( associated(tauaer_sw) ) deallocate(tauaer_sw)
- IF ( associated(ssaaer_sw) ) deallocate(ssaaer_sw)
- IF ( associated(asyaer_sw) ) deallocate(asyaer_sw)
-
- ENDIF Radiation_step
-
- ! jararias, aug 2013
- ! SW surface fluxes interpolation (meaningful when not in a Radiation_step)
- if (swint_opt .eq. 1) then
- call wrf_debug(100,'SW surface irradiance interpolation')
-
- !---------------
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij ,i,j,k,its,ite,jts,jte)
- do ij = 1,num_tiles
- its = i_start(ij)
- ite = i_end(ij)
- jts = j_start(ij)
- jte = j_end(ij)
- call interp_sw_radiation(ims,ime,jms,jme,its,ite,jts,jte, &
- coszen_ref,coszen_loc,swddir_ref, &
- bb,Bx,swdown_ref,gg,Gx,albedo, &
- swdown,swddir,swddni,swddif,gsw )
- enddo
- !$OMP END PARALLEL DO
- end if
-
- ! Coupling with FARMS
- if( present(swdown2 ) .and. &
- present(swddir2 ) .and. &
- present(swddni2 ) .and. &
- present(swddif2 ) .and. &
- present(swdownc2 ) .and. &
- present(swddnic2 ) ) then
- if (swint_opt == 2) then
- call wrf_debug(100,'SW surface irradiance calculated with FARMS')
-
- if (aer_opt == 1) then
- DO j=jts,jte
- DO i=its,ite
- aod5502d(i, j) = aodtot(i, j)
- ENDDO
- ENDDO
- end if
-
- !---------------
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij ,i,j,k,its,ite,jts,jte)
- do ij = 1,num_tiles
- its = i_start(ij)
- ite = i_end(ij)
- jts = j_start(ij)
- jte = j_end(ij)
- call farms_driver (ims, ime, jms, jme, its, ite, jts, jte, kms, kme, kts, kte, &
- p8w, rho, dz8w, albedo, aer_opt, aerssa2d, aerasy2d, aod5502d, angexp2d, &
- coszen_loc, qv, qi, qs, qc, re_cloud, re_ice, re_snow, &
- julian, swdown2, swddir2, swddni2, swddif2, swdownc2, swddnic2, &
- has_reqc, has_reqi, has_reqs, CLDFRA)
- enddo
- !$OMP END PARALLEL DO
- end if
- end if
-
- solar_opt_local = 0
- IF ( PRESENT(solar_opt) ) THEN
- solar_opt_local = solar_opt
- END IF
- IF (run_param .or. solar_opt_local == 1 .or. swint_opt == 2) THEN
- do ij = 1,num_tiles
- its = i_start(ij)
- ite = i_end(ij)
- jts = j_start(ij)
- jte = j_end(ij)
- ! Save resolved + unresolved hydrometeor mass mixing ratios for Solar diag
- IF ( solar_opt_local == 1 ) THEN
- IF ( PRESENT(qc_tot) .AND. PRESENT(qi_tot) ) THEN
- IF ( F_QC ) THEN
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- qc_tot(i,k,j) = qc(i,k,j)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- IF ( F_QI ) THEN
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- qi_tot(i,k,j) = qi(i,k,j)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- END IF
- ENDIF
- ! Restore qc & qi for any model physics configuration
- IF ( F_QC ) THEN
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- qc(i,k,j) = qc_save(i,k,j)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- IF ( F_QI ) THEN
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- qi(i,k,j) = qi_save(i,k,j)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- IF (aercu_opt.gt.0.0) THEN
- IF ( F_QS ) THEN
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- qs(i,k,j) = qs_save(i,k,j)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- END IF
- end do
- END IF
-
- accumulate_lw_select: SELECT CASE(lw_physics)
-
- CASE (CAMLWSCHEME,&
- RRTMG_LWSCHEME &
-#if( BUILD_RRTMG_FAST == 1)
- ,RRTMG_LWSCHEME_FAST &
-#endif
-#if( BUILD_RRTMK == 1)
- ,RRTMK_LWSCHEME &
-#endif
- )
- IF(PRESENT(LWUPTC))THEN
-! NMM calls the driver every RADT time steps, EM calls every DT
-#if (EM_CORE == 1)
- DTaccum = DT
-#else
- DTaccum = RADT*60
-#endif
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij ,i,j,k,its,ite,jts,jte)
-
- DO ij = 1 , num_tiles
- its = i_start(ij)
- ite = i_end(ij)
- jts = j_start(ij)
- jte = j_end(ij)
-
- DO j=jts,jte
- DO i=its,ite
- ACLWUPT(I,J) = ACLWUPT(I,J) + LWUPT(I,J)*DTaccum
- ACLWUPTC(I,J) = ACLWUPTC(I,J) + LWUPTC(I,J)*DTaccum
- ACLWDNT(I,J) = ACLWDNT(I,J) + LWDNT(I,J)*DTaccum
- ACLWDNTC(I,J) = ACLWDNTC(I,J) + LWDNTC(I,J)*DTaccum
- ACLWUPB(I,J) = ACLWUPB(I,J) + LWUPB(I,J)*DTaccum
- ACLWUPBC(I,J) = ACLWUPBC(I,J) + LWUPBC(I,J)*DTaccum
- ACLWDNB(I,J) = ACLWDNB(I,J) + LWDNB(I,J)*DTaccum
- ACLWDNBC(I,J) = ACLWDNBC(I,J) + LWDNBC(I,J)*DTaccum
- ENDDO
- ENDDO
- ENDDO
- !$OMP END PARALLEL DO
- ENDIF
- CASE DEFAULT
- END SELECT accumulate_lw_select
-
- accumulate_sw_select: SELECT CASE(sw_physics)
-
- CASE (CAMSWSCHEME,&
- RRTMG_SWSCHEME &
-#if( BUILD_RRTMG_FAST == 1)
- ,RRTMG_SWSCHEME_FAST &
-#endif
-#if( BUILD_RRTMK == 1)
- ,RRTMK_SWSCHEME &
-#endif
- )
- IF(PRESENT(SWUPTC))THEN
-! NMM calls the driver every RADT time steps, EM calls every DT
-#if (EM_CORE == 1)
- DTaccum = DT
-#else
- DTaccum = RADT*60
-#endif
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij ,i,j,k,its,ite,jts,jte)
-
- DO ij = 1 , num_tiles
- its = i_start(ij)
- ite = i_end(ij)
- jts = j_start(ij)
- jte = j_end(ij)
-
- DO j=jts,jte
- DO i=its,ite
- ACSWUPT(I,J) = ACSWUPT(I,J) + SWUPT(I,J)*DTaccum
- ACSWUPTC(I,J) = ACSWUPTC(I,J) + SWUPTC(I,J)*DTaccum
- ACSWDNT(I,J) = ACSWDNT(I,J) + SWDNT(I,J)*DTaccum
- ACSWDNTC(I,J) = ACSWDNTC(I,J) + SWDNTC(I,J)*DTaccum
- ACSWUPB(I,J) = ACSWUPB(I,J) + SWUPB(I,J)*DTaccum
- ACSWUPBC(I,J) = ACSWUPBC(I,J) + SWUPBC(I,J)*DTaccum
- ACSWDNB(I,J) = ACSWDNB(I,J) + SWDNB(I,J)*DTaccum
- ACSWDNBC(I,J) = ACSWDNBC(I,J) + SWDNBC(I,J)*DTaccum
- ENDDO
- ENDDO
- ENDDO
- !$OMP END PARALLEL DO
- ENDIF
-
- CASE DEFAULT
- END SELECT accumulate_sw_select
-
-! compute cloud diagnosis (random overlapping)
-! by ZCX
- IF ( PRESENT ( CLDFRA ) .AND. PRESENT ( CLDT ) .AND. &
- PRESENT ( F_QC ) .AND. PRESENT ( F_QI ) ) THEN
-
- DO ij = 1 , num_tiles
- its = i_start(ij)
- ite = i_end(ij)
- jts = j_start(ij)
- jte = j_end(ij)
-
- DO j=jts,jte
- DO i=its,ite
- cldji=1.0
- do k=kte-1,kts,-1
- cldji=cldji*(1.0-cldfra(i,k,j))
- enddo
- cldt(i,j)=1.0-cldji
-! cldlji=1.0
-! do k=kte-1,kts,-1
-! if(znu(k).ge.0.69) then
-! cldlji=cldlji*(1.0-cldfra(i,k,j))
-! endif
-! enddo
-! cldl(i,j)=1.0-cldlji
- END DO
- END DO
- END DO
- END IF
-
- END SUBROUTINE radiation_driver
-
- SUBROUTINE pre_radiation_driver ( grid, config_flags &
- ,itimestep, ra_call_offset &
- ,XLAT, XLONG, GMT, julian, xtime, RADT, STEPRA &
- ,ht,dx,dy,dx2d,area2d &
- ,sina,cosa,shadowmask,slope_rad ,topo_shading &
- ,shadlen,ht_shad,ht_loc &
- ,ht_shad_bxs, ht_shad_bxe &
- ,ht_shad_bys, ht_shad_bye &
- ,nested, min_ptchsz &
- ,spec_bdy_width &
- ,ids, ide, jds, jde, kds, kde &
- ,ims, ime, jms, jme, kms, kme &
- ,ips, ipe, jps, jpe, kps, kpe &
- ,i_start, i_end &
- ,j_start, j_end &
- ,kts, kte &
- ,num_tiles )
-
- USE module_domain , ONLY : domain
-#ifdef DM_PARALLEL
- USE module_dm , ONLY : ntasks_x,ntasks_y,local_communicator,mytask,ntasks,wrf_dm_minval_integer
-# if (EM_CORE == 1)
- USE module_comm_dm , ONLY : halo_toposhad_sub
-# endif
-#endif
- USE module_bc
- USE module_model_constants
-
- IMPLICIT NONE
-
- INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- ips,ipe, jps,jpe, kps,kpe, &
- kts,kte, &
- num_tiles
-
- TYPE(domain) , INTENT(INOUT) :: grid
- TYPE(grid_config_rec_type ) , INTENT(IN ) :: config_flags
-
- INTEGER, INTENT(IN ) :: itimestep, ra_call_offset, stepra, &
- slope_rad, topo_shading, &
- spec_bdy_width
-
- INTEGER, INTENT(INOUT) :: min_ptchsz
-
- INTEGER, DIMENSION(num_tiles), INTENT(IN) :: &
- i_start,i_end,j_start,j_end
-
- REAL, INTENT(IN ) :: GMT, radt, julian, xtime, dx, dy, shadlen
-
- REAL, DIMENSION( ims:ime, jms:jme ), &
- INTENT(IN ) :: XLAT, &
- XLONG, &
- HT, &
- SINA, &
- COSA
- REAL, DIMENSION( ims:ime, jms:jme ), &
- INTENT(IN ), OPTIONAL :: DX2D, &
- AREA2D
-
- REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ht_shad,ht_loc
-
- REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), &
- INTENT(IN ) :: ht_shad_bxs, ht_shad_bxe
- REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), &
- INTENT(IN ) :: ht_shad_bys, ht_shad_bye
-
- INTEGER, DIMENSION( ims:ime, jms:jme ), &
- INTENT(INOUT) :: shadowmask
-
- LOGICAL, INTENT(IN ) :: nested
-
-!Local
-! For orographic shading
- INTEGER :: niter,ni,psx,psy,idum,jdum,i,j,ij
- REAL :: DECLIN,SOLCON
-
-! Determine minimum patch size for slope-dependent radiation
- if (itimestep .eq. 1) then
- psx = ipe-ips+1
- psy = jpe-jps+1
- min_ptchsz = min(psx,psy)
- idum = 0
- jdum = 0
- endif
-
-# ifdef DM_PARALLEL
- if (itimestep .eq. 1) then
- call wrf_dm_minval_integer (psx,idum,jdum)
- call wrf_dm_minval_integer (psy,idum,jdum)
- min_ptchsz = min(psx,psy)
- endif
-# endif
-
-! Topographic shading
-
- if ((topo_shading.eq.1).and.(itimestep .eq. 1 .or. &
- mod(itimestep,STEPRA) .eq. 1 + ra_call_offset)) then
-
-!---------------
-! Calculate constants for short wave radiation
-
- CALL radconst(XTIME,DECLIN,SOLCON,JULIAN,DEGRAD,DPD)
-
-! Make a local copy of terrain height field
- do j=jms,jme
- do i=ims,ime
- ht_loc(i,j) = ht(i,j)
- enddo
- enddo
-! Determine if iterations are necessary for shadows to propagate from one patch to another
- if ((ids.eq.ips).and.(ide.eq.ipe).and.(jds.eq.jps).and.(jde.eq.jpe)) then
- niter = 1
- else
- niter = int(shadlen/(dx*min_ptchsz)+3)
- endif
-
-
- IF( nested ) THEN
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij )
-
- DO ij = 1 , num_tiles
-
- CALL spec_bdyfield(ht_shad, &
- ht_shad_bxs, ht_shad_bxe, &
- ht_shad_bys, ht_shad_bye, &
- 'm', config_flags, spec_bdy_width, 2,&
- ids,ide, jds,jde, 1 ,1 , & ! domain dims
- ims,ime, jms,jme, 1 ,1 , & ! memory dims
- ips,ipe, jps,jpe, 1 ,1 , & ! patch dims
- i_start(ij), i_end(ij), &
- j_start(ij), j_end(ij), &
- 1 , 1 )
- ENDDO
- ENDIF
-
- do ni = 1, niter
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij,i,j )
- do ij = 1 , num_tiles
-
- call toposhad_init (ht_shad,ht_loc, &
- shadowmask,nested,ni, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- ips,min(ipe,ide-1), jps,min(jpe,jde-1), kps,kpe, &
- i_start(ij),min(i_end(ij), ide-1),j_start(ij),&
- min(j_end(ij), jde-1), kts, kte )
-
- enddo
- !$OMP END PARALLEL DO
-
-
- !$OMP PARALLEL DO &
- !$OMP PRIVATE ( ij,i,j )
- do ij = 1 , num_tiles
-
- call toposhad (xlat,xlong,sina,cosa,xtime,gmt,radt,declin, &
- dx,dy,ht_shad,ht_loc,ni, &
- shadowmask,shadlen, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- ips,min(ipe,ide-1), jps,min(jpe,jde-1), kps,kpe, &
- i_start(ij),min(i_end(ij), ide-1),j_start(ij),&
- min(j_end(ij), jde-1), kts, kte )
-
- enddo
- !$OMP END PARALLEL DO
-
-#if defined( DM_PARALLEL ) && (EM_CORE == 1)
-# include "HALO_TOPOSHAD.inc"
-#endif
- enddo
- endif
-
- END SUBROUTINE pre_radiation_driver
-
-!---------------------------------------------------------------------
-!BOP
-! !IROUTINE: radconst - compute radiation terms
-! !INTERFAC:
- SUBROUTINE radconst(XTIME,DECLIN,SOLCON,JULIAN, &
- DEGRAD,DPD )
-!---------------------------------------------------------------------
- USE module_wrf_error
- IMPLICIT NONE
-!---------------------------------------------------------------------
-
-! !ARGUMENTS:
- REAL, INTENT(IN ) :: DEGRAD,DPD,XTIME,JULIAN
- REAL, INTENT(OUT ) :: DECLIN,SOLCON
- REAL :: OBECL,SINOB,SXLONG,ARG, &
- DECDEG,DJUL,RJUL,ECCFAC
-!
-! !DESCRIPTION:
-! Compute terms used in radiation physics
-!EOP
-
-! for short wave radiation
-
- DECLIN=0.
- SOLCON=0.
-
-!-----OBECL : OBLIQUITY = 23.5 DEGREE.
-
- OBECL=23.5*DEGRAD
- SINOB=SIN(OBECL)
-
-!-----CALCULATE LONGITUDE OF THE SUN FROM VERNAL EQUINOX:
-
- IF(JULIAN.GE.80.)SXLONG=DPD*(JULIAN-80.)
- IF(JULIAN.LT.80.)SXLONG=DPD*(JULIAN+285.)
- SXLONG=SXLONG*DEGRAD
- ARG=SINOB*SIN(SXLONG)
- DECLIN=ASIN(ARG)
- DECDEG=DECLIN/DEGRAD
-!----SOLAR CONSTANT ECCENTRICITY FACTOR (PALTRIDGE AND PLATT 1976)
- DJUL=JULIAN*360./365.
- RJUL=DJUL*DEGRAD
- ECCFAC=1.000110+0.034221*COS(RJUL)+0.001280*SIN(RJUL)+0.000719* &
- COS(2*RJUL)+0.000077*SIN(2*RJUL)
- SOLCON=1370.*ECCFAC
-
- END SUBROUTINE radconst
-
-
- SUBROUTINE calc_coszen(ims,ime,jms,jme,its,ite,jts,jte, &
- julian,xtime,gmt, &
- declin,degrad,xlon,xlat,coszen,hrang)
- ! Added Equation of Time correction : jararias, 2013/08/10
- implicit none
- integer, intent(in) :: ims,ime,jms,jme,its,ite,jts,jte
- real, intent(in) :: julian,declin,xtime,gmt,degrad
- real, dimension(ims:ime,jms:jme), intent(in) :: xlat,xlon
- real, dimension(ims:ime,jms:jme), intent(inout) :: coszen,hrang
-
- integer :: i,j
- real :: da,eot,xt24,tloctm,xxlat
-
- da=6.2831853071795862*(julian-1)/365.
- eot=(0.000075+0.001868*cos(da)-0.032077*sin(da) &
- -0.014615*cos(2*da)-0.04089*sin(2*da))*(229.18)
- xt24=mod(xtime,1440.)+eot
- do j=jts,jte
- do i=its,ite
- tloctm=gmt+xt24/60.+xlon(i,j)/15.
- hrang(i,j)=15.*(tloctm-12.)*degrad
- xxlat=xlat(i,j)*degrad
- coszen(i,j)=sin(xxlat)*sin(declin) &
- +cos(xxlat)*cos(declin) *cos(hrang(i,j))
- coszen(i, j) = min (max (coszen(i, j), -1.0), 1.0)
- enddo
- enddo
- END SUBROUTINE calc_coszen
-
- subroutine update_swinterp_parameters(ims,ime,jms,jme,its,ite,jts,jte, &
- coszen,coszen_loc,swddir,swdown, &
- swddir_ref,bb,Bx, &
- swdown_ref,gg,Gx, &
- coszen_ref )
- ! Author: jararias 2013/11
- implicit None
- integer, intent(in) :: ims,ime,jms,jme,its,ite,jts,jte
- real, dimension(ims:ime,jms:jme), intent(in) :: coszen,coszen_loc,swddir,swdown
- real, dimension(ims:ime,jms:jme), intent(inout) :: swddir_ref,bb,Bx, &
- swdown_ref,gg,Gx, &
- coszen_ref
-
- integer :: i,j
- real :: swddir_0,swdown_0,coszen_0
- real, parameter :: coszen_min=1e-4
-
- do j=jts,jte
- do i=its,ite
- if ((coszen(i,j).gt.coszen_min) .and. (coszen_loc(i,j).gt.coszen_min)) then
- ! parameters update for DIR
- if (Bx(i,j).le.0) then
- swddir_0 =(coszen_loc(i,j)/coszen(i,j))*swddir(i,j) ! linear first guess estimation
- coszen_0 =coszen_loc(i,j)
- else
- swddir_0 =swddir_ref(i,j)
- coszen_0 =coszen_ref(i,j)
- end if
- if ((coszen(i,j)/coszen_0).lt.1.) then
- bb(i,j) =log(max(1.,swddir(i,j))/max(1.,swddir_0)) / log(min(1.-1e-4,coszen(i,j)/coszen_0))
- elseif ((coszen(i,j)/coszen_0).gt.1) then
- bb(i,j) =log(max(1.,swddir(i,j))/max(1.,swddir_0)) / log(max(1.+1e-4,coszen(i,j)/coszen_0))
- else
- bb(i,j) =0.
- end if
- bb(i,j) =max(-.5,min(2.5,bb(i,j)))
- Bx(i,j) =swddir(i,j)/(coszen(i,j)**bb(i,j))
-
- !write(wrf_err_message,*) 'XXX I=',i,' J=',j,' Bx=',Bx(i,j),' bb=',bb(i,j),' swddir=',swddir(i,j), &
- ! ' swddir_0=',swddir_0,' coszen=',coszen(i,j),' coszen_0=',coszen_0
- !call wrf_debug(1,wrf_err_message)
-
- ! parameters update for GHI
- if (Gx(i,j).le.0) then
- swdown_0 =(coszen_loc(i,j)/coszen(i,j))*swdown(i,j) ! linear first guess estimation
- coszen_0 =coszen_loc(i,j)
- else
- swdown_0 =swdown_ref(i,j)
- coszen_0 =coszen_ref(i,j)
- end if
- if ((coszen(i,j)/coszen_0).lt.1.) then
- gg(i,j) =log(max(1.,swdown(i,j))/max(1.,swdown_0)) / log(min(1.-1e-4,coszen(i,j)/coszen_0))
- elseif ((coszen(i,j)/coszen_0).gt.1) then
- gg(i,j) =log(max(1.,swdown(i,j))/max(1.,swdown_0)) / log(max(1.+1e-4,coszen(i,j)/coszen_0))
- else
- gg(i,j) =0.
- end if
- gg(i,j) =max(-.5,min(2.5,gg(i,j)))
- Gx(i,j) =swdown(i,j)/(coszen(i,j)**gg(i,j))
- else
- Bx(i,j) =0.
- bb(i,j) =0.
- Gx(i,j) =0.
- gg(i,j) =0.
- end if
-
- ! saving last SW run in state variables
- coszen_ref(i,j) =coszen(i,j)
- swdown_ref(i,j) =swdown(i,j)
- swddir_ref(i,j) =swddir(i,j)
-
- !if ((i.eq.20).and.(j.eq.20)) then
- ! write(wrf_err_message,'(" RADSTEP : tn=",I4," csz_0=",F9.6," csz=",F9.6," csz_1=",F9.6," Gx=",F14.2," gg=",F9.5, &
- ! " Bx=",F14.2," bb=",F9.5)') itimestep,coszen_0,coszen_loc(i,j),coszen(i,j),Gx(i,j),gg(i,j), &
- ! Bx(i,j),bb(i,j)
- ! call wrf_debug(1,wrf_err_message)
- !end if
-
- end do
- end do
-
- end subroutine update_swinterp_parameters
-
- subroutine interp_sw_radiation(ims,ime,jms,jme,its,ite,jts,jte, &
- coszen_ref,coszen_loc,swddir_ref, &
- bb,Bx,swdown_ref,gg,Gx,albedo, &
- swdown,swddir,swddni,swddif,gsw )
- ! Author: jararias 2013/11
- implicit None
- integer, intent(in) :: ims,ime,jms,jme,its,ite,jts,jte
- real, dimension(ims:ime,jms:jme), intent(in) :: coszen_ref,coszen_loc, &
- swddir_ref,Bx,bb, &
- swdown_ref,Gx,gg, &
- albedo
-
- real, dimension(ims:ime,jms:jme), intent(inout) :: swddir,swdown, &
- swddif,swddni, gsw
-
- integer :: i,j
- real, parameter :: coszen_min=1e-4
-
- do j=jts,jte
- do i=its,ite
- ! sza interpolation of surface fluxes
- if ((coszen_ref(i,j).gt.coszen_min) .and. (coszen_loc(i,j).gt.coszen_min)) then
- if ((bb(i,j).eq.-0.5).or.(bb(i,j).eq.2.5).or.(bb(i,j).eq.0.0)) then
- swddir(i,j) =(coszen_loc(i,j)/coszen_ref(i,j))*swddir_ref(i,j)
- else
- swddir(i,j) =Bx(i,j)*(coszen_loc(i,j)**bb(i,j))
- end if
- if ((gg(i,j).eq.-0.5).or.(gg(i,j).eq.2.5).or.(gg(i,j).eq.0.0)) then
- swdown(i,j) =(coszen_loc(i,j)/coszen_ref(i,j))*swdown_ref(i,j)
- else
- swdown(i,j) =Gx(i,j)*(coszen_loc(i,j)**gg(i,j))
- end if
- swddif(i,j) =swdown(i,j)-swddir(i,j)
- swddni(i,j) =swddir(i,j)/coszen_loc(i,j)
- gsw(i,j) =swdown(i,j)*(1.-albedo(i,j))
- else
- swddir(i,j) =0.
- swdown(i,j) =0.
- swddif(i,j) =0.
- swddni(i,j) =0.
- gsw(i,j) =0.
- end if
- end do
- end do
- end subroutine interp_sw_radiation
-
-!---------------------------------------------------------------------
-!BOP
-! !IROUTINE: cal_cldfra2 - Compute cloud fraction
-! !INTERFACE:
- SUBROUTINE cal_cldfra2(CLDFRA,QC,QI,F_QC,F_QI, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte )
- USE module_state_description, ONLY : KFCUPSCHEME, KFETASCHEME !CuP, wig 5-Oct-2006 !BSINGH - For WRFCuP scheme
-!---------------------------------------------------------------------
- IMPLICIT NONE
-!---------------------------------------------------------------------
- INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte
-
-!
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(OUT ) :: &
- CLDFRA
-
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: &
- QI, &
- QC
- LOGICAL,INTENT(IN) :: F_QC,F_QI
-
- REAL thresh
- INTEGER:: i,j,k
-! !DESCRIPTION:
-! Compute cloud fraction from input ice and cloud water fields
-! if provided.
-!
-! Whether QI or QC is active or not is determined from the indices of
-! the fields into the 4D scalar arrays in WRF. These indices are
-! P_QI and P_QC, respectively, and they are passed in to the routine
-! to enable testing to see if QI and QC represent active fields in
-! the moisture 4D scalar array carried by WRF.
-!
-! If a field is active its index will have a value greater than or
-! equal to PARAM_FIRST_SCALAR, which is also an input argument to
-! this routine.
-!EOP
-!---------------------------------------------------------------------
- thresh=1.0e-6
-
- IF ( f_qi .AND. f_qc ) THEN
- DO j = jts,jte
- DO k = kts,kte
- DO i = its,ite
- IF ( QC(i,k,j)+QI(I,k,j) .gt. thresh) THEN
- CLDFRA(i,k,j)=1.
- ELSE
- CLDFRA(i,k,j)=0.
- ENDIF
- ENDDO
- ENDDO
- ENDDO
- ELSE IF ( f_qc ) THEN
- DO j = jts,jte
- DO k = kts,kte
- DO i = its,ite
- IF ( QC(i,k,j) .gt. thresh) THEN
- CLDFRA(i,k,j)=1.
- ELSE
- CLDFRA(i,k,j)=0.
- ENDIF
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO j = jts,jte
- DO k = kts,kte
- DO i = its,ite
- CLDFRA(i,k,j)=0.
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- END SUBROUTINE cal_cldfra2
-
-!BOP
-! !IROUTINE: cal_cldfra1 - Compute cloud fraction
-! !INTERFACE:
-! cal_cldfra_xr - Compute cloud fraction.
-! Code adapted from that in module_ra_gfdleta.F in WRF_v2.0.3 by James Done
-!!
-!!--- Cloud fraction parameterization follows Xu and Randall (JAS), 1996
-!! (see Hong et al., 1998)
-!! (modified by Ferrier, Feb '02)
-!
- SUBROUTINE cal_cldfra1(CLDFRA, QV, QC, QI, QS, &
- F_QV, F_QC, F_QI, F_QS, t_phy, p_phy, &
- F_ICE_PHY,F_RAIN_PHY, &
- mp_physics, cldfra1_flag, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte )
- USE module_state_description, ONLY : KFCUPSCHEME, KFETASCHEME !wig, CuP 4-Fb-2008 !BSINGH - For WRFCuP scheme
-
-#if (HWRF == 1)
- USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT, ETAMP_HWRF
-#else
- USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT
-#endif
-!---------------------------------------------------------------------
- IMPLICIT NONE
-!---------------------------------------------------------------------
- INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte
-
-!
- INTEGER, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(OUT ) :: cldfra1_flag
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(OUT ) :: &
- CLDFRA
-
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: &
- QV, &
- QI, &
- QC, &
- QS, &
- t_phy, &
- p_phy
-! p_phy, &
-! F_ICE_PHY, &
-! F_RAIN_PHY
-
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
- OPTIONAL, &
- INTENT(IN ) :: &
- F_ICE_PHY, &
- F_RAIN_PHY
- LOGICAL,OPTIONAL,INTENT(IN) :: F_QC,F_QI,F_QV,F_QS
- INTEGER :: mp_physics
-
-! REAL thresh
- INTEGER:: i,j,k
- REAL :: RHUM, tc, esw, esi, weight, qvsw, qvsi, qvs_weight, QIMID, QWMID, QCLD, DENOM, ARG, SUBSAT
-
- REAL ,PARAMETER :: ALPHA0=100., GAMMA=0.49, QCLDMIN=1.E-12, &
- PEXP=0.25, RHGRID=1.0
- REAL , PARAMETER :: SVP1=0.61078
- REAL , PARAMETER :: SVP2=17.2693882
- REAL , PARAMETER :: SVPI2=21.8745584
- REAL , PARAMETER :: SVP3=35.86
- REAL , PARAMETER :: SVPI3=7.66
- REAL , PARAMETER :: SVPT0=273.15
- REAL , PARAMETER :: r_d = 287.
- REAL , PARAMETER :: r_v = 461.6
- REAL , PARAMETER :: ep_2=r_d/r_v
-! !DESCRIPTION:
-! Compute cloud fraction from input ice and cloud water fields
-! if provided.
-!
-! Whether QI or QC is active or not is determined from the indices of
-! the fields into the 4D scalar arrays in WRF. These indices are
-! P_QI and P_QC, respectively, and they are passed in to the routine
-! to enable testing to see if QI and QC represent active fields in
-! the moisture 4D scalar array carried by WRF.
-!
-! If a field is active its index will have a value greater than or
-! equal to PARAM_FIRST_SCALAR, which is also an input argument to
-! this routine.
-!EOP
-
-
-!-----------------------------------------------------------------------
-!--- COMPUTE GRID-SCALE CLOUD COVER FOR RADIATION
-! (modified by Ferrier, Feb '02)
-!
-!--- Cloud fraction parameterization follows Randall, 1994
-! (see Hong et al., 1998)
-!-----------------------------------------------------------------------
-! Note: ep_2=287./461.6 Rd/Rv
-! Note: R_D=287.
-
-! Alternative calculation for critical RH for grid saturation
-! RHGRID=0.90+.08*((100.-DX)/95.)**.5
-
-! Calculate saturation mixing ratio weighted according to the fractions of
-! water and ice.
-! Following:
-! Murray, F.W. 1966. ``On the computation of Saturation Vapor Pressure'' J. Appl. Meteor. 6 p.204
-! es (in mb) = 6.1078 . exp[ a . (T-273.16)/ (T-b) ]
-!
-! over ice over water
-! a = 21.8745584 17.2693882
-! b = 7.66 35.86
-
-!---------------------------------------------------------------------
-
- DO j = jts,jte
- DO k = kts,kte
- DO i = its,ite
- tc = t_phy(i,k,j) - SVPT0
- esw = 1000.0 * SVP1 * EXP( SVP2 * tc / ( t_phy(i,k,j) - SVP3 ) )
- esi = 1000.0 * SVP1 * EXP( SVPI2 * tc / ( t_phy(i,k,j) - SVPI3 ) )
- QVSW = EP_2 * esw / ( p_phy(i,k,j) - esw )
- QVSI = EP_2 * esi / ( p_phy(i,k,j) - esi )
-
- ifouter: IF ( PRESENT(F_QI) .and. PRESENT(F_QC) .and. PRESENT(F_QS) ) THEN
-
-! mji - For MP options 2, 4, 6, 7, 8, etc. (qc = liquid, qi = ice, qs = snow)
- IF ( F_QI .and. F_QC .and. F_QS) THEN
- QCLD = QI(i,k,j)+QC(i,k,j)+QS(i,k,j)
- IF (QCLD .LT. QCLDMIN) THEN
- weight = 0.
- ELSE
- weight = (QI(i,k,j)+QS(i,k,j)) / QCLD
- ENDIF
- ENDIF
-
-! for P3, mp option 50 or 51
- IF ( F_QI .and. F_QC .and. .not. F_QS) THEN
- QCLD = QI(i,k,j)+QC(i,k,j)
- IF (QCLD .LT. QCLDMIN) THEN
- weight = 0.
- ELSE
- weight = (QI(i,k,j)) / QCLD
- ENDIF
- ENDIF
-
-! mji - For MP options 1 and 3, (qc only)
-! For MP=1, qc = liquid, for MP=3, qc = liquid or ice depending on temperature
- IF ( F_QC .and. .not. F_QI .and. .not. F_QS ) THEN
- QCLD = QC(i,k,j)
- IF (QCLD .LT. QCLDMIN) THEN
- weight = 0.
- ELSE
- if (t_phy(i,k,j) .gt. 273.15) weight = 0.
- if (t_phy(i,k,j) .le. 273.15) weight = 1.
- ENDIF
- ENDIF
-
-! mji - For MP option 5; (qc = liquid, qs = ice)
- IF ( F_QC .and. .not. F_QI .and. F_QS .and. PRESENT(F_ICE_PHY) ) THEN
-
-! Mixing ratios of cloud water & total ice (cloud ice + snow).
-! Mixing ratios of rain are not considered in this scheme.
-! F_ICE is fraction of ice
-! F_RAIN is fraction of rain
-
- QIMID = QS(i,k,j)
- QWMID = QC(i,k,j)
-! old method
-! QIMID = QC(i,k,j)*F_ICE_PHY(i,k,j)
-! QWMID = (QC(i,k,j)-QIMID)*(1.-F_RAIN_PHY(i,k,j))
-!
-!--- Total "cloud" mixing ratio, QCLD. Rain is not part of cloud,
-! only cloud water + cloud ice + snow
-!
- QCLD=QWMID+QIMID
- IF (QCLD .LT. QCLDMIN) THEN
- weight = 0.
- ELSE
- weight = F_ICE_PHY(i,k,j)
- ENDIF
- ENDIF
-!BSF - For HWRF MP option; (qc = liquid, qi = cloud ice+snow)
-! IF ( F_QC .and. F_QI .and. .not. F_QS ) THEN
-#if (HWRF == 1)
- IF ( mp_physics .eq. FER_MP_HIRES .or. &
- mp_physics .eq. FER_MP_HIRES_ADVECT .or. &
- mp_physics .eq. ETAMP_HWRF) THEN
-#else
- IF ( mp_physics .eq. FER_MP_HIRES .or. &
- mp_physics==fer_mp_hires_advect) THEN
-#endif
- QIMID = QI(i,k,j) !- total ice (cloud ice + snow)
- QWMID = QC(i,k,j) !- cloud water
- QCLD=QWMID+QIMID !- cloud water + total ice
- IF (QCLD .LT. QCLDMIN) THEN
- weight = 0.
- ELSE
- weight = QIMID/QCLD
- if (tc<-40.) weight=1.
- ENDIF
- ENDIF
-
- ELSE
- CLDFRA(i,k,j)=0.
-
- ENDIF ifouter ! IF ( F_QI .and. F_QC .and. F_QS)
-
-
- QVS_WEIGHT = (1-weight)*QVSW + weight*QVSI
- RHUM=QV(i,k,j)/QVS_WEIGHT !--- Relative humidity
-!
-!--- Determine cloud fraction (modified from original algorithm)
-!
- cldfra1_flag(i,k,j) = 0
- IF (QCLD .LT. QCLDMIN) THEN
-!
-!--- Assume zero cloud fraction if there is no cloud mixing ratio
-!
- CLDFRA(i,k,j)=0.
- cldfra1_flag(i,k,j) = 1
- ELSEIF(RHUM.GE.RHGRID)THEN
-!
-!--- Assume cloud fraction of unity if near saturation and the cloud
-! mixing ratio is at or above the minimum threshold
-!
- CLDFRA(i,k,j)=1.
- cldfra1_flag(i,k,j) = 2
- ELSE
- cldfra1_flag(i,k,j) = 3
-!
-!--- Adaptation of original algorithm (Randall, 1994; Zhao, 1995)
-! modified based on assumed grid-scale saturation at RH=RHgrid.
-!
- SUBSAT=MAX(1.E-10,RHGRID*QVS_WEIGHT-QV(i,k,j))
- DENOM=(SUBSAT)**GAMMA
- ARG=MAX(-6.9, -ALPHA0*QCLD/DENOM) ! <-- EXP(-6.9)=.001
-! prevent negative values (new)
- RHUM=MAX(1.E-10, RHUM)
- CLDFRA(i,k,j)=(RHUM/RHGRID)**PEXP*(1.-EXP(ARG))
-!! ARG=-1000*QCLD/(RHUM-RHGRID)
-!! ARG=MAX(ARG, ARGMIN)
-!! CLDFRA(i,k,j)=(RHUM/RHGRID)*(1.-EXP(ARG))
- IF (CLDFRA(i,k,j) .LT. .01) CLDFRA(i,k,j)=0.
-
- ENDIF !--- End IF (QCLD .LT. QCLDMIN) ...
- ENDDO !--- End DO i
- ENDDO !--- End DO k
- ENDDO !--- End DO j
-
- END SUBROUTINE cal_cldfra1
-
-!+---+-----------------------------------------------------------------+
-!..Cloud fraction scheme by G. Thompson (NCAR-RAL), not intended for
-!.. combining with any cumulus or shallow cumulus parameterization
-!.. scheme cloud fractions. This is intended as a stand-alone for
-!.. cloud fraction and is relatively good at getting widespread stratus
-!.. and stratoCu without caring whether any deep/shallow Cu param schemes
-!.. is making sub-grid-spacing clouds/precip. Under the hood, this
-!.. scheme follows Mocko and Cotton (1995) in applicaiton of the
-!.. Sundqvist et al (1989) scheme but using a grid-scale dependent
-!.. RH threshold, one each for land v. ocean points based on
-!.. experiences with HWRF testing.
-!+---+-----------------------------------------------------------------+
-!
-!+---+-----------------------------------------------------------------+
-
- SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, &
- & p, t, XLAND, gridkm, &
- & modify_qvapor, max_relh, &
- & kts,kte, debug_flag)
-!
- USE module_mp_thompson , ONLY : rsif, rslf
- IMPLICIT NONE
-!
- INTEGER, INTENT(IN):: kts, kte
- LOGICAL, INTENT(IN):: modify_qvapor
- REAL, DIMENSION(kts:kte), INTENT(INOUT):: qv, qc, qi, cldfra
- REAL, DIMENSION(kts:kte), INTENT(IN):: p, t, dz, qs
- REAL, INTENT(IN):: gridkm, XLAND, max_relh
- LOGICAL, INTENT(IN):: debug_flag
-
-!..Local vars.
- REAL:: RH_00L, RH_00O, RH_00
- REAL:: entrmnt=0.5
- INTEGER:: k
- REAL:: TC, qvsi, qvsw, RHUM, delz
- REAL, DIMENSION(kts:kte):: qvs, rh, rhoa
-
- character*512 dbg_msg
-
-!+---+
-
-!..Initialize cloud fraction, compute RH, and rho-air.
-
- DO k = kts,kte
- CLDFRA(K) = 0.0
-
- qvsw = rslf(P(k), t(k))
- qvsi = rsif(P(k), t(k))
-
- tc = t(k) - 273.15
- if (tc .ge. -12.0) then
- qvs(k) = qvsw
- elseif (tc .lt. -35.0) then
- qvs(k) = qvsi
- else
- qvs(k) = qvsw - (qvsw-qvsi)*(-12.0-tc)/(-12.0+35.)
- endif
-
- if (modify_qvapor) then
- if (qc(k).gt.1.E-8) then
- qv(k) = MAX(qv(k), qvsw)
- qvs(k) = qvsw
- endif
- if (qc(k).le.1.E-8 .and. qi(k).ge.1.E-9) then
- qv(k) = MAX(qv(k), qvsi*1.005) !..To ensure a tiny bit ice supersaturation
- qvs(k) = qvsi
- endif
- endif
-
- rh(k) = MAX(0.01, qv(k)/qvs(k))
- rhoa(k) = p(k)/(287.0*t(k))
- ENDDO
-
-
-!..First cut scale-aware. Higher resolution should require closer to
-!.. saturated grid box for higher cloud fraction. Simple functions
-!.. chosen based on Mocko and Cotton (1995) starting point and desire
-!.. to get near 100% RH as grid spacing moves toward 1.0km, but higher
-!.. RH over ocean required as compared to over land.
-
- DO k = kts,kte
-
- delz = MAX(100., dz(k))
- RH_00L = 0.53 + MIN(0.46,SQRT(1./(50.0+gridkm*gridkm*delz*0.01)))
- RH_00O = 0.86 + MIN(0.13,SQRT(1./(50.0+gridkm*gridkm*delz*0.01)))
- RHUM = rh(k)
-
- if (qc(k).gt.1.E-6 .or. qi(k).ge.1.E-6 &
- & .or. (qs(k).gt.1.E-5 .and. t(k).lt.273.)) then
- CLDFRA(K) = 1.0
- else
-
- IF ((XLAND-1.5).GT.0.) THEN !--- Ocean
- RH_00 = RH_00O
- ELSE !--- Land
- RH_00 = RH_00L
- ENDIF
-
- tc = t(k) - 273.15
- if (tc .lt. -12.0) RH_00 = RH_00L
-
- if (tc .ge. 29.0) then
- CLDFRA(K) = 0.0
- elseif (tc .ge. -12.0) then
- RHUM = MIN(rh(k), 1.0)
- CLDFRA(K) = MAX(0., 1.0-SQRT((1.001-RHUM)/(1.001-RH_00)))
- else
- if (max_relh.gt.1.12 .or. (.NOT.(modify_qvapor)) ) then
-!..For HRRR model, the following look OK.
- RHUM = MIN(rh(k), 1.45)
- RH_00 = RH_00 + (1.45-RH_00)*(-12.0-tc)/(-12.0+112.)
- if (RH_00 .ge. 1.5) then
- WRITE (dbg_msg,*) ' FATAL: RH_00 too large (1.5): ', RH_00, RH_00L, tc
- CALL wrf_error_fatal (dbg_msg)
- endif
- CLDFRA(K) = MAX(0., 1.0-SQRT((1.46-RHUM)/(1.46-RH_00)))
- else
-!..but for the GFS model, RH is way lower.
- RHUM = MIN(rh(k), 1.05)
- RH_00 = RH_00 + (1.05-RH_00)*(-12.0-tc)/(-12.0+112.)
- if (RH_00 .ge. 1.05) then
- WRITE (dbg_msg,*) ' FATAL: RH_00 too large (1.05): ', RH_00, RH_00L, tc
- CALL wrf_error_fatal (dbg_msg)
- endif
- CLDFRA(K) = MAX(0., 1.0-SQRT((1.06-RHUM)/(1.06-RH_00)))
- endif
- endif
- if (CLDFRA(K).gt.0.) CLDFRA(K) = MAX(0.01, MIN(CLDFRA(K),0.95))
-
- if (debug_flag) then
- WRITE (dbg_msg,*) 'DEBUG-GT: cloud fraction (k,RH_00, RHUM, CF): ',k,RH_00,RHUM,CLDFRA(K)
- CALL wrf_debug (150, dbg_msg)
- endif
-
- endif
- ENDDO
-
-
- call find_cloudLayers(qvs, cldfra, T, P, Dz, entrmnt, &
- & debug_flag, qc, qi, qs, kts,kte)
-
-!..Do a final total column adjustment since we may have added more than 1mm
-!.. LWP/IWP for multiple cloud decks.
-
- call adjust_cloudFinal(cldfra, qc, qi, rhoa, dz, kts,kte)
-
- if (debug_flag) then
- WRITE (dbg_msg,*) 'DEBUG-GT: Made-up fake profile of clouds'
- CALL wrf_debug (150, dbg_msg)
- do k = kte, kts, -1
- write(dbg_msg,'(f7.2,2x,f7.2,2x,f6.4,2x,f7.3,x,f15.7,x,f15.7,x,f15.7)') &
- & T(k)-273.15, P(k)*0.01, rh(k), cldfra(k)*100., qc(k)*1000.,qi(k)*1000., qs(k)*1000.
- CALL wrf_debug (150, dbg_msg)
- enddo
- endif
-
-
- if (modify_qvapor) then
- DO k = kts,kte
- if (cldfra(k).gt.0.20 .and. cldfra(k).lt.1.0) then
- qv(k) = MAX(qv(k),qvs(k))
- endif
- ENDDO
- endif
-
-
- END SUBROUTINE cal_cldfra3
-
-!+---+-----------------------------------------------------------------+
-!..From cloud fraction array, find clouds of multi-level depth and compute
-!.. a reasonable value of LWP or IWP that might be contained in that depth,
-!.. unless existing LWC/IWC is already there.
-
- SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, Dz1d, entrmnt,&
- & debugfl, qc1d, qi1d, qs1d, kts,kte)
-!
- IMPLICIT NONE
-!
- INTEGER, INTENT(IN):: kts, kte
- LOGICAL, INTENT(IN):: debugfl
- REAL, INTENT(IN):: entrmnt
- REAL, DIMENSION(kts:kte), INTENT(IN):: qs1d,qvs1d,T1d,P1d,Dz1d
- REAL, DIMENSION(kts:kte), INTENT(INOUT):: cfr1d, qc1d, qi1d
-
-!..Local vars.
- REAL, DIMENSION(kts:kte):: theta
- REAL:: theta1, theta2, delz
- INTEGER:: k, k2, k_tropo, k_m12C, k_cldb, k_cldt, kbot, k_p150
- LOGICAL:: in_cloud
- character*512 dbg_msg
-
-!+---+
-
- k_m12C = 0
- k_p150 = 0
- DO k = kte, kts, -1
- theta(k) = T1d(k)*((100000.0/P1d(k))**(287.05/1004.))
- if (T1d(k)-273.16 .gt. -12.0 .and. P1d(k).gt.10100.0) k_m12C = MAX(k_m12C, k)
- if (P1d(k).gt.14999.0 .and. k_p150.eq.0) k_p150 = k
- ENDDO
- if (k_m12C .le. kts) k_m12C = kts
-
- if (k_m12C.gt.kte-3) then
- WRITE (dbg_msg,*) 'DEBUG-GT: WARNING, no possible way neg12C can occur this high up: ', k_m12C
- CALL wrf_debug (0, dbg_msg)
- do k = kte, kts, -1
- WRITE (dbg_msg,*) 'DEBUG-GT, k, P, T : ', k,P1d(k)*0.01,T1d(k)-273.15
- CALL wrf_debug (0, dbg_msg)
- enddo
- call wrf_error_fatal ('FATAL ERROR, problem in temperature profile.')
- endif
-
-!..Find tropopause height, best surrogate, because we would not really
-!.. wish to put fake clouds into the stratosphere. The 10/1500 ratio
-!.. d(Theta)/d(Z) approximates a vertical line on typical SkewT chart
-!.. near typical (mid-latitude) tropopause height. Since messy data
-!.. could give us a false signal of such a transition, do the check over
-!.. three K-level change, not just a level-to-level check. This method
-!.. has potential failure in arctic-like conditions with extremely low
-!.. tropopause height, as would any other diagnostic, so ensure resulting
-!.. k_tropo level is above 700hPa.
-
- if ( (kte-k_p150) .lt. 3) k_p150 = kte-3
- DO k = k_p150-2, kts, -1
- theta1 = theta(k)
- theta2 = theta(k+2)
- delz = 0.5*dz1d(k) + dz1d(k+1) + 0.5*dz1d(k+2)
- if ( (((theta2-theta1)/delz).lt.10./1500.) .OR. P1d(k).gt.70000.) EXIT
- ENDDO
- k_tropo = MAX(kts+2, MIN(k+2, kte-1))
-
- if (k_tropo .gt. k_p150) then
- DO k = kte-3, k_p150-2, -1
- theta1 = theta(k)
- theta2 = theta(k+2)
- delz = 0.5*dz1d(k) + dz1d(k+1) + 0.5*dz1d(k+2)
- if ( (((theta2-theta1)/delz).lt.10./1500.) .AND. P1d(k).gt.9500.) EXIT
- ENDDO
- k_tropo = MAX(k_p150-1, MIN(k+2, kte-1))
- endif
-
- if (k_tropo.gt.kte-2) then
- WRITE (dbg_msg,*) 'DEBUG-GT: CAUTION, tropopause appears to be very high up: ', k_tropo
- CALL wrf_debug (150, dbg_msg)
- do k = kte, kts, -1
- WRITE (dbg_msg,*) 'DEBUG-GT, P, T : ', k,P1d(k)*0.01,T1d(k)-273.16
- CALL wrf_debug (150, dbg_msg)
- enddo
- elseif (debugfl) then
- WRITE (dbg_msg,*) 'DEBUG-GT: FOUND TROPOPAUSE k=', k_tropo
- CALL wrf_debug (150, dbg_msg)
- endif
-
-!..Eliminate possible fractional clouds above supposed tropopause.
- DO k = k_tropo+1, kte
- if (cfr1d(k).gt.0.0 .and. cfr1d(k).lt.1.0) then
- cfr1d(k) = 0.
- endif
- ENDDO
-
-!..Be a bit more conservative with lower cloud fraction in scenario with
-!.. well-mixed convective boundary layer below LCL.
-
- kbot = kts+1
- DO k = kbot, k_m12C
- if ( (theta(k)-theta(k-1)) .gt. 0.010E-3*Dz1d(k)) EXIT
- ENDDO
- kbot = MAX(kts+1, k-2)
- DO k = kts, kbot
- if (cfr1d(k).gt.0.0 .and. cfr1d(k).lt.1.0) cfr1d(k) = MAX(0.01,0.5*cfr1d(k))
- ENDDO
- DO k = kts,k_tropo
- if (cfr1d(k).gt.0.0) kbot = MIN(k,kbot)
- ENDDO
-
-!..Starting below tropo height, if cloud fraction greater than 1 percent,
-!.. compute an approximate total layer depth of cloud, determine a total
-!.. liquid water/ice path (LWP/IWP), then reduce that amount with tuning
-!.. parameter to represent entrainment factor, then divide up LWP/IWP
-!.. into delta-Z weighted amounts for individual levels per cloud layer.
-
- k_cldb = k_tropo
- in_cloud = .false.
- k = k_tropo
- DO WHILE (.not. in_cloud .AND. k.gt.k_m12C+1)
- k_cldt = 0
- if (cfr1d(k).ge.0.01) then
- in_cloud = .true.
- k_cldt = MAX(k_cldt, k)
- endif
- if (in_cloud) then
- DO k2 = k_cldt-1, k_m12C, -1
- if (cfr1d(k2).lt.0.01 .or. k2.eq.k_m12C) then
- k_cldb = k2+1
- goto 87
- endif
- ENDDO
- 87 continue
- in_cloud = .false.
- endif
- if ((k_cldt - k_cldb + 1) .ge. 2) then
- if (debugfl) then
- WRITE (dbg_msg,*) 'DEBUG-GT: An ice cloud layer is found between ', k_cldt, k_cldb, P1d(k_cldt)*0.01, P1d(k_cldb)*0.01
- CALL wrf_debug (150, dbg_msg)
- endif
- call adjust_cloudIce(cfr1d, qi1d, qs1d, qvs1d, T1d, Dz1d, &
- & entrmnt, k_cldb,k_cldt,kts,kte)
- k = k_cldb
- elseif ((k_cldt - k_cldb + 1) .eq. 1) then
- if (debugfl) then
- WRITE (dbg_msg,*) 'DEBUG-GT: A single-layer ice cloud layer is found on ', k_cldb, P1d(k_cldb)*0.01
- CALL wrf_debug (150, dbg_msg)
- endif
- if (cfr1d(k_cldb).gt.0.and.cfr1d(k_cldb).lt.1.) &
- & qi1d(k_cldb)=qi1d(k_cldb)+0.05*qvs1d(k_cldb)*cfr1d(k_cldb)
- k = k_cldb
- endif
- k = k - 1
- ENDDO
-
-
- k_cldb = k_m12C + 5
- in_cloud = .false.
- k = k_m12C + 4
- DO WHILE (.not. in_cloud .AND. k.gt.kbot)
- k_cldt = 0
- if (cfr1d(k).ge.0.01) then
- in_cloud = .true.
- k_cldt = MAX(k_cldt, k)
- endif
- if (in_cloud) then
- DO k2 = k_cldt-1, kbot, -1
- if (cfr1d(k2).lt.0.01 .or. k2.eq.kbot) then
- k_cldb = k2+1
- goto 88
- endif
- ENDDO
- 88 continue
- in_cloud = .false.
- endif
- if ((k_cldt - k_cldb + 1) .ge. 2) then
- if (debugfl) then
- WRITE (dbg_msg,*) 'DEBUG-GT: A water cloud layer is found between ', k_cldt, k_cldb, P1d(k_cldt)*0.01, P1d(k_cldb)*0.01
- CALL wrf_debug (150, dbg_msg)
- endif
- call adjust_cloudH2O(cfr1d, qc1d, qvs1d, T1d, Dz1d, &
- & entrmnt, k_cldb,k_cldt,kts,kte)
- k = k_cldb
- elseif ((k_cldt - k_cldb + 1) .eq. 1) then
- if (cfr1d(k_cldb).gt.0.and.cfr1d(k_cldb).lt.1.) &
- & qc1d(k_cldb)=qc1d(k_cldb)+0.05*qvs1d(k_cldb)*cfr1d(k_cldb)
- k = k_cldb
- endif
- k = k - 1
- ENDDO
-
-
- END SUBROUTINE find_cloudLayers
-
-!+---+-----------------------------------------------------------------+
-
- SUBROUTINE adjust_cloudIce(cfr,qi,qs,qvs,T,dz,entr, k1,k2,kts,kte)
-!
- IMPLICIT NONE
-!
- INTEGER, INTENT(IN):: k1,k2, kts,kte
- REAL, INTENT(IN):: entr
- REAL, DIMENSION(kts:kte), INTENT(IN):: cfr, qs, qvs, T, dz
- REAL, DIMENSION(kts:kte), INTENT(INOUT):: qi
- REAL:: iwc, max_iwc, tdz, this_iwc, this_dz
- INTEGER:: k
-
- tdz = 0.
- do k = k1, k2
- tdz = tdz + dz(k)
- enddo
- max_iwc = ABS(qvs(k2)-qvs(k1))
-! print*, ' max_iwc = ', max_iwc, ' over DZ=',tdz
-
- do k = k1, k2
- max_iwc = MAX(1.E-5, max_iwc - (qi(k)+qs(k)))
- enddo
- max_iwc = MIN(2.E-3, max_iwc)
-
- this_dz = 0.0
- do k = k1, k2
- if (k.eq.k1) then
- this_dz = this_dz + 0.5*dz(k)
- else
- this_dz = this_dz + dz(k)
- endif
- this_iwc = max_iwc*this_dz/tdz
- iwc = MAX(5.E-6, this_iwc*(1.-entr))
- if (cfr(k).gt.0.0.and.cfr(k).lt.1.0.and.T(k).ge.203.16) then
- qi(k) = qi(k) + cfr(k)*cfr(k)*iwc
- endif
- enddo
-
- END SUBROUTINE adjust_cloudIce
-
-!+---+-----------------------------------------------------------------+
-
- SUBROUTINE adjust_cloudH2O(cfr, qc, qvs,T,dz,entr, k1,k2,kts,kte)
-!
- IMPLICIT NONE
-!
- INTEGER, INTENT(IN):: k1,k2, kts,kte
- REAL, INTENT(IN):: entr
- REAL, DIMENSION(kts:kte), INTENT(IN):: cfr, qvs, T, dz
- REAL, DIMENSION(kts:kte), INTENT(INOUT):: qc
- REAL:: lwc, max_lwc, tdz, this_lwc, this_dz
- INTEGER:: k
-
- tdz = 0.
- do k = k1, k2
- tdz = tdz + dz(k)
- enddo
- max_lwc = ABS(qvs(k2)-qvs(k1))
-! print*, ' max_lwc = ', max_lwc, ' over DZ=',tdz
-
- do k = k1, k2
- max_lwc = MAX(1.E-5, max_lwc - qc(k))
- enddo
- max_lwc = MIN(2.E-3, max_lwc)
-
- this_dz = 0.0
- do k = k1, k2
- if (k.eq.k1) then
- this_dz = this_dz + 0.5*dz(k)
- else
- this_dz = this_dz + dz(k)
- endif
- this_lwc = max_lwc*this_dz/tdz
- lwc = MAX(5.E-6, this_lwc*(1.-entr))
- if (cfr(k).gt.0.0.and.cfr(k).lt.1.0.and.T(k).ge.253.16) then
- qc(k) = qc(k) + cfr(k)*cfr(k)*lwc
- endif
- enddo
-
- END SUBROUTINE adjust_cloudH2O
-
-!+---+-----------------------------------------------------------------+
-
-!..Do not alter any grid-explicitly resolved hydrometeors, rather only
-!.. the supposed amounts due to the cloud fraction scheme.
-
- SUBROUTINE adjust_cloudFinal(cfr, qc, qi, Rho,dz, kts,kte)
-!
- IMPLICIT NONE
-!
- INTEGER, INTENT(IN):: kts,kte
- REAL, DIMENSION(kts:kte), INTENT(IN):: cfr, Rho, dz
- REAL, DIMENSION(kts:kte), INTENT(INOUT):: qc, qi
- REAL:: lwp, iwp, xfac
- INTEGER:: k
-
- lwp = 0.
- iwp = 0.
- do k = kts, kte
- if (cfr(k).gt.0.0 .and. cfr(k).lt.1.0) then
- lwp = lwp + qc(k)*Rho(k)*dz(k)
- iwp = iwp + qi(k)*Rho(k)*dz(k)
- endif
- enddo
-
- if (lwp .gt. 1.0) then
- xfac = 1.0/lwp
- do k = kts, kte
- if (cfr(k).gt.0.0 .and. cfr(k).lt.1.0) then
- qc(k) = qc(k)*xfac
- endif
- enddo
- endif
-
- if (iwp .gt. 1.0) then
- xfac = 1.0/iwp
- do k = kts, kte
- if (cfr(k).gt.0.0 .and. cfr(k).lt.1.0) then
- qi(k) = qi(k)*xfac
- endif
- enddo
- endif
-
- END SUBROUTINE adjust_cloudFinal
-
-
-!+---+-----------------------------------------------------------------+
-
- SUBROUTINE toposhad_init(ht_shad,ht_loc,shadowmask,nested,iter, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- ips,ipe, jps,jpe, kps,kpe, &
- its,ite, jts,jte, kts,kte )
-
- USE module_model_constants
-
- implicit none
-
- INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- ips,ipe, jps,jpe, kps,kpe, &
- its,ite, jts,jte, kts,kte
-
- LOGICAL, INTENT(IN) :: nested
-
- REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ht_shad, ht_loc
-
- INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: shadowmask
- INTEGER, INTENT(IN) :: iter
-
-! Local variables
-
- INTEGER :: i, j
-
- if (iter.eq.1) then
-
-! Initialize shadow mask
- do j=jts,jte
- do i=its,ite
- shadowmask(i,j) = 0
- ENDDO
- ENDDO
-
-! Initialize shading height
-
- IF ( nested ) THEN ! Do not overwrite input from parent domain
- do j=max(jts,jds+2),min(jte,jde-3)
- do i=max(its,ids+2),min(ite,ide-3)
- ht_shad(i,j) = ht_loc(i,j)-0.001
- ENDDO
- ENDDO
- ELSE
- do j=jts,jte
- do i=its,ite
- ht_shad(i,j) = ht_loc(i,j)-0.001
- ENDDO
- ENDDO
- ENDIF
-
- IF ( nested ) THEN ! Check if a shadow exceeding the topography height is available at the lateral domain edge from nesting
- if (its.eq.ids) then
- do j=jts,jte
- if (ht_shad(its,j) .gt. ht_loc(its,j)) then
- shadowmask(its,j) = 1
- ht_loc(its,j) = ht_shad(its,j)
- endif
- if (ht_shad(its+1,j) .gt. ht_loc(its+1,j)) then
- shadowmask(its+1,j) = 1
- ht_loc(its+1,j) = ht_shad(its+1,j)
- endif
- enddo
- endif
- if (ite.eq.ide-1) then
- do j=jts,jte
- if (ht_shad(ite,j) .gt. ht_loc(ite,j)) then
- shadowmask(ite,j) = 1
- ht_loc(ite,j) = ht_shad(ite,j)
- endif
- if (ht_shad(ite-1,j) .gt. ht_loc(ite-1,j)) then
- shadowmask(ite-1,j) = 1
- ht_loc(ite-1,j) = ht_shad(ite-1,j)
- endif
- enddo
- endif
- if (jts.eq.jds) then
- do i=its,ite
- if (ht_shad(i,jts) .gt. ht_loc(i,jts)) then
- shadowmask(i,jts) = 1
- ht_loc(i,jts) = ht_shad(i,jts)
- endif
- if (ht_shad(i,jts+1) .gt. ht_loc(i,jts+1)) then
- shadowmask(i,jts+1) = 1
- ht_loc(i,jts+1) = ht_shad(i,jts+1)
- endif
- enddo
- endif
- if (jte.eq.jde-1) then
- do i=its,ite
- if (ht_shad(i,jte) .gt. ht_loc(i,jte)) then
- shadowmask(i,jte) = 1
- ht_loc(i,jte) = ht_shad(i,jte)
- endif
- if (ht_shad(i,jte-1) .gt. ht_loc(i,jte-1)) then
- shadowmask(i,jte-1) = 1
- ht_loc(i,jte-1) = ht_shad(i,jte-1)
- endif
- enddo
- endif
- ENDIF
-
- else
-
-! Fill the local topography field at the points next to internal tile boundaries with ht_shad values
-! A 2-pt halo has been applied to the ht_shad before the repeated call of this subroutine
-
- if ((its.ne.ids).and.(its.eq.ips)) then
- do j=jts-2,jte+2
- ht_loc(its-1,j) = max(ht_loc(its-1,j),ht_shad(its-1,j))
- ht_loc(its-2,j) = max(ht_loc(its-2,j),ht_shad(its-2,j))
- enddo
- endif
- if ((ite.ne.ide-1).and.(ite.eq.ipe)) then
- do j=jts-2,jte+2
- ht_loc(ite+1,j) = max(ht_loc(ite+1,j),ht_shad(ite+1,j))
- ht_loc(ite+2,j) = max(ht_loc(ite+2,j),ht_shad(ite+2,j))
- enddo
- endif
- if ((jts.ne.jds).and.(jts.eq.jps)) then
- do i=its-2,ite+2
- ht_loc(i,jts-1) = max(ht_loc(i,jts-1),ht_shad(i,jts-1))
- ht_loc(i,jts-2) = max(ht_loc(i,jts-2),ht_shad(i,jts-2))
- enddo
- endif
- if ((jte.ne.jde-1).and.(jte.eq.jpe)) then
- do i=its-2,ite+2
- ht_loc(i,jte+1) = max(ht_loc(i,jte+1),ht_shad(i,jte+1))
- ht_loc(i,jte+2) = max(ht_loc(i,jte+2),ht_shad(i,jte+2))
- enddo
- endif
-
- endif
-
- END SUBROUTINE toposhad_init
-
- SUBROUTINE toposhad(xlat,xlong,sina,cosa,xtime,gmt,radfrq,declin, &
- dx,dy,ht_shad,ht_loc,iter, &
- shadowmask,shadlen, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- ips,ipe, jps,jpe, kps,kpe, &
- its,ite, jts,jte, kts,kte )
-
-
- USE module_model_constants
-
- implicit none
-
- INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- ips,ipe, jps,jpe, kps,kpe, &
- its,ite, jts,jte, kts,kte
-
- INTEGER, INTENT(IN) :: iter
-
- REAL, INTENT(IN) :: RADFRQ,XTIME,DECLIN,dx,dy,gmt,shadlen
-
- REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: XLAT, XLONG, sina, cosa
-
- REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ht_shad,ht_loc
-
- INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: shadowmask
-
-! Local variables
-
- REAL :: pi, xt24, wgt, ri, rj, argu, sol_azi, topoelev, dxabs, tloctm, hrang, xxlat, csza
- INTEGER :: gpshad, ii, jj, i1, i2, j1, j2, i, j
-
-
-
- XT24=MOD(XTIME+RADFRQ*0.5,1440.)
- pi = 4.*atan(1.)
- gpshad = int(shadlen/dx+1.)
-
- if (iter.eq.1) then
-
-
- j_loop1: DO J=jts,jte
- i_loop1: DO I=its,ite
-
- TLOCTM=GMT+XT24/60.+XLONG(i,j)/15.
- HRANG=15.*(TLOCTM-12.)*DEGRAD
- XXLAT=XLAT(i,j)*DEGRAD
- CSZA=SIN(XXLAT)*SIN(DECLIN)+COS(XXLAT)*COS(DECLIN)*COS(HRANG)
-
- if (csza.lt.1.e-2) then ! shadow mask does not need to be computed
- shadowmask(i,j) = 0
- ht_shad(i,j) = ht_loc(i,j)-0.001
- goto 120
- endif
-
-! Solar azimuth angle
-
- argu=(csza*sin(XXLAT)-sin(DECLIN))/(sin(acos(csza))*cos(XXLAT))
- if (argu.gt.1) argu = 1
- if (argu.lt.-1) argu = -1
- sol_azi = sign(acos(argu),sin(HRANG))+pi ! azimuth angle of the sun
- if (cosa(i,j).ge.0) then
- sol_azi = sol_azi + asin(sina(i,j)) ! rotation towards WRF grid
- else
- sol_azi = sol_azi + pi - asin(sina(i,j))
- endif
-
-! Scan for higher surrounding topography
-
- if ((sol_azi.gt.1.75*pi).or.(sol_azi.lt.0.25*pi)) then ! sun is in the northern quarter
-
- do jj = j+1,j+gpshad
- ri = i + (jj-j)*tan(sol_azi)
- i1 = int(ri)
- i2 = i1+1
- wgt = ri-i1
- dxabs = sqrt((dy*(jj-j))**2+(dx*(ri-i))**2)
- if ((jj.ge.jpe+3).or.(i1.le.ips-3).or.(i2.ge.ipe+3)) then
-! if (shadowmask(i,j).eq.0) shadowmask(i,j) = -1
- goto 120
- endif
- topoelev=atan((wgt*ht_loc(i2,jj)+(1.-wgt)*ht_loc(i1,jj)-ht_loc(i,j))/dxabs)
- if (sin(topoelev).ge.csza) then
- shadowmask(i,j) = 1
- ht_shad(i,j) = max(ht_shad(i,j),ht_loc(i,j)+dxabs*(tan(topoelev)-tan(asin(csza))))
- endif
- enddo
-
- else if (sol_azi.lt.0.75*pi) then ! sun is in the eastern quarter
- do ii = i+1,i+gpshad
- rj = j - (ii-i)*tan(pi/2.+sol_azi)
- j1 = int(rj)
- j2 = j1+1
- wgt = rj-j1
- dxabs = sqrt((dx*(ii-i))**2+(dy*(rj-j))**2)
- if ((ii.ge.ipe+3).or.(j1.le.jps-3).or.(j2.ge.jpe+3)) then
-! if (shadowmask(i,j).eq.0) shadowmask(i,j) = -1
- goto 120
- endif
- topoelev=atan((wgt*ht_loc(ii,j2)+(1.-wgt)*ht_loc(ii,j1)-ht_loc(i,j))/dxabs)
- if (sin(topoelev).ge.csza) then
- shadowmask(i,j) = 1
- ht_shad(i,j) = max(ht_shad(i,j),ht_loc(i,j)+dxabs*(tan(topoelev)-tan(asin(csza))))
- endif
- enddo
-
- else if (sol_azi.lt.1.25*pi) then ! sun is in the southern quarter
- do jj = j-1,j-gpshad,-1
- ri = i + (jj-j)*tan(sol_azi)
- i1 = int(ri)
- i2 = i1+1
- wgt = ri-i1
- dxabs = sqrt((dy*(jj-j))**2+(dx*(ri-i))**2)
- if ((jj.le.jps-3).or.(i1.le.ips-3).or.(i2.ge.ipe+3)) then
-! if (shadowmask(i,j).eq.0) shadowmask(i,j) = -1
- goto 120
- endif
- topoelev=atan((wgt*ht_loc(i2,jj)+(1.-wgt)*ht_loc(i1,jj)-ht_loc(i,j))/dxabs)
- if (sin(topoelev).ge.csza) then
- shadowmask(i,j) = 1
- ht_shad(i,j) = max(ht_shad(i,j),ht_loc(i,j)+dxabs*(tan(topoelev)-tan(asin(csza))))
- endif
- enddo
-
- else ! sun is in the western quarter
- do ii = i-1,i-gpshad,-1
- rj = j - (ii-i)*tan(pi/2.+sol_azi)
- j1 = int(rj)
- j2 = j1+1
- wgt = rj-j1
- dxabs = sqrt((dx*(ii-i))**2+(dy*(rj-j))**2)
- if ((ii.le.ips-3).or.(j1.le.jps-3).or.(j2.ge.jpe+3)) then
-! if (shadowmask(i,j).eq.0) shadowmask(i,j) = -1
- goto 120
- endif
- topoelev=atan((wgt*ht_loc(ii,j2)+(1.-wgt)*ht_loc(ii,j1)-ht_loc(i,j))/dxabs)
- if (sin(topoelev).ge.csza) then
- shadowmask(i,j) = 1
- ht_shad(i,j) = max(ht_shad(i,j),ht_loc(i,j)+dxabs*(tan(topoelev)-tan(asin(csza))))
- endif
- enddo
- endif
-
- 120 continue
-
- ENDDO i_loop1
- ENDDO j_loop1
-
- else ! iteration > 1
-
-
- j_loop2: DO J=jts,jte
- i_loop2: DO I=its,ite
-
-! if (shadowmask(i,j).eq.-1) then ! this indicates that the search ended at a lateral boundary during iteration 1
-
- TLOCTM=GMT+XT24/60.+XLONG(i,j)/15.
- HRANG=15.*(TLOCTM-12.)*DEGRAD
- XXLAT=XLAT(i,j)*DEGRAD
- CSZA=SIN(XXLAT)*SIN(DECLIN)+COS(XXLAT)*COS(DECLIN)*COS(HRANG)
-
- if (csza.lt.1.e-2) then ! shadow mask does not need to be computed
- shadowmask(i,j) = 0
- ht_shad(i,j) = ht_loc(i,j)-0.001
- goto 220
- endif
-
-! Solar azimuth angle
-
- argu=(csza*sin(XXLAT)-sin(DECLIN))/(sin(acos(csza))*cos(XXLAT))
- if (argu.gt.1) argu = 1
- if (argu.lt.-1) argu = -1
- sol_azi = sign(acos(argu),sin(HRANG))+pi ! azimuth angle of the sun
- if (cosa(i,j).ge.0) then
- sol_azi = sol_azi + asin(sina(i,j)) ! rotation towards WRF grid
- else
- sol_azi = sol_azi + pi - asin(sina(i,j))
- endif
-
-! Scan for higher surrounding topography
-
- if ((sol_azi.gt.1.75*pi).or.(sol_azi.lt.0.25*pi)) then ! sun is in the northern quarter
-
- do jj = j+1,j+gpshad
- ri = i + (jj-j)*tan(sol_azi)
- i1 = int(ri)
- i2 = i1+1
- wgt = ri-i1
- dxabs = sqrt((dy*(jj-j))**2+(dx*(ri-i))**2)
- if ((jj.ge.min(jde,jpe+3)).or.(i1.le.max(ids-1,ips-3)).or.(i2.ge.min(ide,ipe+3))) goto 220
- topoelev=atan((wgt*ht_loc(i2,jj)+(1.-wgt)*ht_loc(i1,jj)-ht_loc(i,j))/dxabs)
- if (sin(topoelev).ge.csza) then
- shadowmask(i,j) = 1
- ht_shad(i,j) = max(ht_shad(i,j),ht_loc(i,j)+dxabs*(tan(topoelev)-tan(asin(csza))))
- endif
- enddo
-
- else if (sol_azi.lt.0.75*pi) then ! sun is in the eastern quarter
- do ii = i+1,i+gpshad
- rj = j - (ii-i)*tan(pi/2.+sol_azi)
- j1 = int(rj)
- j2 = j1+1
- wgt = rj-j1
- dxabs = sqrt((dx*(ii-i))**2+(dy*(rj-j))**2)
- if ((ii.ge.min(ide,ipe+3)).or.(j1.le.max(jds-1,jps-3)).or.(j2.ge.min(jde,jpe+3))) goto 220
- topoelev=atan((wgt*ht_loc(ii,j2)+(1.-wgt)*ht_loc(ii,j1)-ht_loc(i,j))/dxabs)
- if (sin(topoelev).ge.csza) then
- shadowmask(i,j) = 1
- ht_shad(i,j) = max(ht_shad(i,j),ht_loc(i,j)+dxabs*(tan(topoelev)-tan(asin(csza))))
- endif
- enddo
-
- else if (sol_azi.lt.1.25*pi) then ! sun is in the southern quarter
- do jj = j-1,j-gpshad,-1
- ri = i + (jj-j)*tan(sol_azi)
- i1 = int(ri)
- i2 = i1+1
- wgt = ri-i1
- dxabs = sqrt((dy*(jj-j))**2+(dx*(ri-i))**2)
- if ((jj.le.max(jds-1,jps-3)).or.(i1.le.max(ids-1,ips-3)).or.(i2.ge.min(ide,ipe+3))) goto 220
- topoelev=atan((wgt*ht_loc(i2,jj)+(1.-wgt)*ht_loc(i1,jj)-ht_loc(i,j))/dxabs)
- if (sin(topoelev).ge.csza) then
- shadowmask(i,j) = 1
- ht_shad(i,j) = max(ht_shad(i,j),ht_loc(i,j)+dxabs*(tan(topoelev)-tan(asin(csza))))
- endif
- enddo
-
- else ! sun is in the western quarter
- do ii = i-1,i-gpshad,-1
- rj = j - (ii-i)*tan(pi/2.+sol_azi)
- j1 = int(rj)
- j2 = j1+1
- wgt = rj-j1
- dxabs = sqrt((dx*(ii-i))**2+(dy*(rj-j))**2)
- if ((ii.le.max(ids-1,ips-3)).or.(j1.le.max(jds-1,jps-3)).or.(j2.ge.min(jde,jpe+3))) goto 220
- topoelev=atan((wgt*ht_loc(ii,j2)+(1.-wgt)*ht_loc(ii,j1)-ht_loc(i,j))/dxabs)
- if (sin(topoelev).ge.csza) then
- shadowmask(i,j) = 1
- ht_shad(i,j) = max(ht_shad(i,j),ht_loc(i,j)+dxabs*(tan(topoelev)-tan(asin(csza))))
- endif
- enddo
- endif
-
- 220 continue
-! endif
-
- ENDDO i_loop2
- ENDDO j_loop2
-
- endif ! iteration
-
- END SUBROUTINE toposhad
-
-SUBROUTINE ozn_time_int(julday,julian,ozmixm,ozmixt,levsiz,num_months, &
- ids , ide , jds , jde , kds , kde , &
- ims , ime , jms , jme , kms , kme , &
- its , ite , jts , jte , kts , kte )
-
-! adapted from oznint from CAM module
-! input: ozmixm - read from physics_init
-! output: ozmixt - time interpolated
-
-! USE module_ra_cam_support, ONLY : getfactors
-
- 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, levsiz, jms:jme, num_months ), &
- INTENT(IN ) :: ozmixm
-
- INTEGER, INTENT(IN ) :: JULDAY
- REAL, INTENT(IN ) :: JULIAN
-
- REAL, DIMENSION( ims:ime, levsiz, jms:jme ), &
- INTENT(OUT ) :: ozmixt
-
- !Local
- REAL :: intJULIAN
- integer :: np1,np,nm,m,k,i,j
- integer :: IJUL
- integer, dimension(12) :: date_oz
- data date_oz/16, 45, 75, 105, 136, 166, 197, 228, 258, 289, 319, 350/
- real, parameter :: daysperyear = 365. ! number of days in a year
- real :: cdayozp, cdayozm
- real :: fact1, fact2, deltat
- logical :: finddate
- logical :: ozncyc
- CHARACTER(LEN=256) :: msgstr
-
- ozncyc = .true.
- ! JULIAN starts from 0.0 at 0Z on 1 Jan.
- intJULIAN = JULIAN + 1.0 ! 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)
-!
-! Determine time interpolation factors. Account for December-January
-! interpolation if dataset is being cycled yearly.
-!
- if (ozncyc .and. np1 == 1) then ! Dec-Jan interpolation
- deltat = cdayozp + daysperyear - cdayozm
- if (intjulian > cdayozp) then ! We are in December
- fact1 = (cdayozp + daysperyear - intjulian)/deltat
- fact2 = (intjulian - cdayozm)/deltat
- else ! We are in January
- fact1 = (cdayozp - intjulian)/deltat
- fact2 = (intjulian + daysperyear - cdayozm)/deltat
- end if
- else
- deltat = cdayozp - cdayozm
- fact1 = (cdayozp - intjulian)/deltat
- fact2 = (intjulian - cdayozm)/deltat
- end if
-!
-! Time interpolation.
-!
- do j=jts,jte
- do k=1,levsiz
- do i=its,ite
- ozmixt(i,k,j) = ozmixm(i,k,j,nm+1)*fact1 + ozmixm(i,k,j,np+1)*fact2
- end do
- end do
- end do
-
-END SUBROUTINE ozn_time_int
-
-SUBROUTINE ozn_p_int(p ,pin, levsiz, ozmixt, o3vmr, &
- ids , ide , jds , jde , kds , kde , &
- ims , ime , jms , jme , kms , kme , &
- its , ite , jts , jte , kts , kte )
-
-!-----------------------------------------------------------------------
-!
-! Purpose: Interpolate ozone from current time-interpolated values to model levels
-!
-! Method: Use pressure values to determine interpolation levels
-!
-! Author: Bruce Briegleb
-! WW: Adapted for general use
-!
-!--------------------------------------------------------------------------
- implicit none
-!--------------------------------------------------------------------------
-!
-! Arguments
-!
- 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 ! number of ozone layers
-
- real, intent(in) :: p(ims:ime,kms:kme,jms:jme) ! level pressures (mks, bottom-up)
- real, intent(in) :: pin(levsiz) ! ozone data level pressures (mks, top-down)
- real, intent(in) :: ozmixt(ims:ime,levsiz,jms:jme) ! ozone mixing ratio
-
- real, intent(out) :: o3vmr(ims:ime,kms:kme,jms:jme) ! ozone volume mixing ratio
-!
-! local storage
-!
- real pmid(its:ite,kts:kte)
- integer i,j ! longitude index
- integer k, kk, kkstart, kout! level indices
- integer kupper(its:ite) ! Level indices for interpolation
- integer kount ! Counter
- integer ncol, pver
-
- real dpu ! upper level pressure difference
- real dpl ! lower level pressure difference
-
- ncol = ite - its + 1
- pver = kte - kts + 1
-
- do j=jts,jte
-!
-! Initialize index array
-!
-! do i=1, ncol
- do i=its, ite
- kupper(i) = 1
- end do
-!
-! Reverse the pressure array, and pin is in Pa, the same as model pmid
-!
- do k = kts,kte
- kk = kte - k + kts
- do i = its,ite
- pmid(i,kk) = p(i,k,j)
- enddo
- enddo
-
- do k=1,pver
-
- kout = pver - k + 1
-! kout = k
-!
-! 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
- do i=its,ite
- kkstart = min0(kkstart,kupper(i))
- end do
- kount = 0
-!
-! Store level indices for interpolation
-!
- do kk=kkstart,levsiz-1
-! do i=1,ncol
- do i=its,ite
- 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
- do i=its,ite
- dpu = pmid(i,k) - pin(kupper(i))
- dpl = pin(kupper(i)+1) - pmid(i,k)
- o3vmr(i,kout,j) = (ozmixt(i,kupper(i),j)*dpl + &
- ozmixt(i,kupper(i)+1,j)*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
- do i=its,ite
- if (pmid(i,k) .lt. pin(1)) then
- o3vmr(i,kout,j) = ozmixt(i,1,j)*pmid(i,k)/pin(1)
- else if (pmid(i,k) .gt. pin(levsiz)) then
- o3vmr(i,kout,j) = ozmixt(i,levsiz,j)
- else
- dpu = pmid(i,k) - pin(kupper(i))
- dpl = pin(kupper(i)+1) - pmid(i,k)
- o3vmr(i,kout,j) = (ozmixt(i,kupper(i),j)*dpl + &
- ozmixt(i,kupper(i)+1,j)*dpu)/(dpl + dpu)
- end if
- end do
-
- if (kount.gt.ncol) then
-! call endrun ('OZN_P_INT: Bad ozone data: non-monotonicity suspected')
- call wrf_error_fatal ('OZN_P_INT: Bad ozone data: non-monotonicity suspected')
- end if
-35 continue
-
- end do
- end do
-
- return
-END SUBROUTINE ozn_p_int
-
-SUBROUTINE aer_time_int(julday,julian,aerodm,aerodt,levsiz,num_months,no_src, &
- ids , ide , jds , jde , kds , kde , &
- ims , ime , jms , jme , kms , kme , &
- its , ite , jts , jte , kts , kte )
-
-! adapted from oznint from CAM module
-! input: aerodm - read from physics_init
-! output: aerodt - time interpolated
-
-! USE module_ra_cam_support, ONLY : getfactors
-
- 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, no_src
-
- REAL, DIMENSION( ims:ime, levsiz, jms:jme, num_months, no_src ), &
- INTENT(IN ) :: aerodm
-
- INTEGER, INTENT(IN ) :: JULDAY
- REAL, INTENT(IN ) :: JULIAN
-
- REAL, DIMENSION( ims:ime, levsiz, jms:jme, no_src ), &
- INTENT(OUT ) :: aerodt
-
- !Local
- REAL :: intJULIAN
- integer :: np1,np,nm,m,k,i,j,s
- integer :: IJUL
- integer, dimension(12) :: date_oz
- data date_oz/16, 45, 75, 105, 136, 166, 197, 228, 258, 289, 319, 350/
- real, parameter :: daysperyear = 365. ! number of days in a year
- real :: cdayozp, cdayozm
- real :: fact1, fact2, deltat
- logical :: finddate
- logical :: ozncyc
- CHARACTER(LEN=256) :: msgstr
-
- ozncyc = .true.
- ! JULIAN starts from 0.0 at 0Z on 1 Jan.
- intJULIAN = JULIAN + 1.0 ! 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)
-!
-! Determine time interpolation factors. Account for December-January
-! interpolation if dataset is being cycled yearly.
-!
- if (ozncyc .and. np1 == 1) then ! Dec-Jan interpolation
- deltat = cdayozp + daysperyear - cdayozm
- if (intjulian > cdayozp) then ! We are in December
- fact1 = (cdayozp + daysperyear - intjulian)/deltat
- fact2 = (intjulian - cdayozm)/deltat
- else ! We are in January
- fact1 = (cdayozp - intjulian)/deltat
- fact2 = (intjulian + daysperyear - cdayozm)/deltat
- end if
- else
- deltat = cdayozp - cdayozm
- fact1 = (cdayozp - intjulian)/deltat
- fact2 = (intjulian - cdayozm)/deltat
- end if
-!
-! Time interpolation.
-!
- do s=1, no_src
- do j=jts,jte
- do k=1,levsiz
- do i=its,ite
- aerodt(i,k,j,s) = aerodm(i,k,j,nm,s)*fact1 + aerodm(i,k,j,np,s)*fact2
- end do
- end do
- end do
- end do
-
-END SUBROUTINE aer_time_int
-
-SUBROUTINE aer_p_int(p ,pin, levsiz, aerodt, aerod, no_src, pf, totaod, &
- ids , ide , jds , jde , kds , kde , &
- ims , ime , jms , jme , kms , kme , &
- its , ite , jts , jte , kts , kte )
-
-!-----------------------------------------------------------------------
-!
-! Purpose: Interpolate aerosol from current time-interpolated values to model levels
-!
-! Method: Use pressure values to determine interpolation levels
-!
-! Author: Bruce Briegleb
-! WW: Adapted for general use
-!
-! p: model level pressure at half levels (Pa, bottom-up)
-! pf: model level pressure at full levles (Pa, bottom-up)
-!
-!--------------------------------------------------------------------------
- implicit none
-!--------------------------------------------------------------------------
-!
-! Arguments
-!
- 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 ! number of aerosol layers
- integer, intent(in) :: no_src ! types of aerosol
-
- real, intent(in) :: p(ims:ime,kms:kme,jms:jme)
- real, intent(in) :: pf(ims:ime,kms:kme,jms:jme)
- real, intent(in) :: pin(levsiz) ! aerosol data level pressures (mks, top-down)
- real, intent(in) :: aerodt(ims:ime,levsiz,jms:jme,1:no_src) ! aerosol optical depth
-
- real, intent(out) :: aerod(ims:ime,kms:kme,jms:jme,1:no_src) ! aerosol optical depth
- real, intent(out) :: totaod(ims:ime,jms:jme) ! total aerosol optical depth
-!
-! local storage
-!
- real pmid(its:ite,kts:kte)
- integer i,j ! longitude index
- integer k, kk, kkstart, kout! level indices
- integer kupper(its:ite) ! Level indices for interpolation
- integer kount ! Counter
- integer ncol, pver, s
-
- real dpu ! upper level pressure difference
- real dpl ! lower level pressure difference
- real dpm ! pressure difference in a model layer surrounding half p
-
- ncol = ite - its + 1
- pver = kte - kts + 1
-
- do s=1,no_src
- do j=jts,jte
-!
-! Initialize index array
-!
- do i=its, ite
- kupper(i) = 1
- end do
-!
-! The pressure from incoming data is in hPa and top-down,
-! while model pressure is in Pa and bottom-up
-!
- do k = kts,kte
- kk = kte - k + kts
- do i = its,ite
- pmid(i,kk) = p(i,k,j)*0.01
- enddo
- enddo
-
- do k=1,pver
-
- kout = pver - k + 1
-!
-! Top level we need to start looking is the top level for the previous k
-! for all longitude points
-!
- kkstart = levsiz
- do i=its,ite
- kkstart = min0(kkstart,kupper(i))
- end do
- kount = 0
-!
-! Store level indices for interpolation
-!
- do kk=kkstart,levsiz-1
- do i=its,ite
- 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=its,ite
- dpu = pmid(i,k) - pin(kupper(i))
- dpl = pin(kupper(i)+1) - pmid(i,k)
- dpm = pf(i,kout,j) - pf(i,kout+1,j)
- aerod(i,kout,j,s) = (aerodt(i,kupper(i),j,s)*dpl + &
- aerodt(i,kupper(i)+1,j,s)*dpu)/(dpl + dpu)
- aerod(i,kout,j,s) = aerod(i,kout,j,s)*dpm
- 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 aerosol data level for at least some
-! of the longitude points.
-!
- do i=its,ite
- if (pmid(i,k) .lt. pin(1)) then
- dpm = pf(i,kout,j) - pf(i,kout+1,j)
- aerod(i,kout,j,s) = aerodt(i,1,j,s)*pmid(i,k)/pin(1)
- aerod(i,kout,j,s) = aerod(i,kout,j,s)*dpm
- else if (pmid(i,k) .gt. pin(levsiz)) then
- dpm = pf(i,kout,j) - pf(i,kout+1,j)
- aerod(i,kout,j,s) = aerodt(i,levsiz,j,s)
- aerod(i,kout,j,s) = aerod(i,kout,j,s)*dpm
- else
- dpu = pmid(i,k) - pin(kupper(i))
- dpl = pin(kupper(i)+1) - pmid(i,k)
- dpm = pf(i,kout,j) - pf(i,kout+1,j)
- aerod(i,kout,j,s) = (aerodt(i,kupper(i),j,s)*dpl + &
- aerodt(i,kupper(i)+1,j,s)*dpu)/(dpl + dpu)
- aerod(i,kout,j,s) = aerod(i,kout,j,s)*dpm
- end if
- end do
-
- if (kount.gt.ncol) then
- call wrf_error_fatal ('AER_P_INT: Bad aerosol data: non-monotonicity suspected')
- end if
-35 continue
-
- end do
- end do
- end do
-
- do j=jts,jte
- do i=its,ite
- totaod(i,j) = 0.
- end do
- end do
-
- do s=1,no_src
- do j=jts,jte
- do k=1,pver
- do i=its,ite
- totaod(i,j) = totaod(i,j) + aerod(i,k,j,s)
- end do
- end do
- end do
- end do
-
- return
-END SUBROUTINE aer_p_int
-
-
-!+---+-----------------------------------------------------------------+
-
- SUBROUTINE gt_aod(p_phy,DZ8W,t_phy,qvapor, nwfa,nifa, taod5503d, &
- & ims,ime, jms,jme, kms,kme, its,ite, jts,jte, kts,kte)
-
- USE module_mp_thompson, only: RSLF
-
- IMPLICIT NONE
-
- INTEGER, INTENT(IN):: ims,ime, jms,jme, kms,kme, &
- & its,ite, jts,jte, kts,kte
-
- REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN) :: &
- & t_phy,p_phy, DZ8W, &
- & qvapor, nifa, nwfa
- REAL,DIMENSION(ims:ime,kms:kme,jms:jme),INTENT(INOUT):: taod5503d
-
- !..Local variables.
-
- REAL, DIMENSION(its:ite,kts:kte,jts:jte):: AOD_wfa, AOD_ifa
- REAL:: RH, a_RH,b_RH, rh_d,rh_f, rhoa,qvsat, unit_bext1,unit_bext3
- REAL:: ntemp
- INTEGER :: i, k, j, RH_idx, RH_idx1, RH_idx2, t_idx
- INTEGER, PARAMETER:: rind=8
- REAL, DIMENSION(rind), PARAMETER:: rh_arr = &
- & (/10., 60., 70., 80., 85., 90., 95., 99.8/)
- REAL, DIMENSION(rind,4,2) :: lookup_tabl ! RH, temp, water-friendly, ice-friendly
-
- lookup_tabl(1,1,1) = 5.73936E-15
- lookup_tabl(1,1,2) = 2.63577E-12
- lookup_tabl(1,2,1) = 5.73936E-15
- lookup_tabl(1,2,2) = 2.63577E-12
- lookup_tabl(1,3,1) = 5.73936E-15
- lookup_tabl(1,3,2) = 2.63577E-12
- lookup_tabl(1,4,1) = 5.73936E-15
- lookup_tabl(1,4,2) = 2.63577E-12
-
- lookup_tabl(2,1,1) = 6.93515E-15
- lookup_tabl(2,1,2) = 2.72095E-12
- lookup_tabl(2,2,1) = 6.93168E-15
- lookup_tabl(2,2,2) = 2.72092E-12
- lookup_tabl(2,3,1) = 6.92570E-15
- lookup_tabl(2,3,2) = 2.72091E-12
- lookup_tabl(2,4,1) = 6.91833E-15
- lookup_tabl(2,4,2) = 2.72087E-12
-
- lookup_tabl(3,1,1) = 7.24707E-15
- lookup_tabl(3,1,2) = 2.77219E-12
- lookup_tabl(3,2,1) = 7.23809E-15
- lookup_tabl(3,2,2) = 2.77222E-12
- lookup_tabl(3,3,1) = 7.23108E-15
- lookup_tabl(3,3,2) = 2.77201E-12
- lookup_tabl(3,4,1) = 7.21800E-15
- lookup_tabl(3,4,2) = 2.77111E-12
-
- lookup_tabl(4,1,1) = 8.95130E-15
- lookup_tabl(4,1,2) = 2.87263E-12
- lookup_tabl(4,2,1) = 9.01582E-15
- lookup_tabl(4,2,2) = 2.87252E-12
- lookup_tabl(4,3,1) = 9.13216E-15
- lookup_tabl(4,3,2) = 2.87241E-12
- lookup_tabl(4,4,1) = 9.16219E-15
- lookup_tabl(4,4,2) = 2.87211E-12
-
- lookup_tabl(5,1,1) = 1.06695E-14
- lookup_tabl(5,1,2) = 2.96752E-12
- lookup_tabl(5,2,1) = 1.06370E-14
- lookup_tabl(5,2,2) = 2.96726E-12
- lookup_tabl(5,3,1) = 1.05999E-14
- lookup_tabl(5,3,2) = 2.96702E-12
- lookup_tabl(5,4,1) = 1.05443E-14
- lookup_tabl(5,4,2) = 2.96603E-12
-
- lookup_tabl(6,1,1) = 1.37908E-14
- lookup_tabl(6,1,2) = 3.15081E-12
- lookup_tabl(6,2,1) = 1.37172E-14
- lookup_tabl(6,2,2) = 3.15020E-12
- lookup_tabl(6,3,1) = 1.36362E-14
- lookup_tabl(6,3,2) = 3.14927E-12
- lookup_tabl(6,4,1) = 1.35287E-14
- lookup_tabl(6,4,2) = 3.14817E-12
-
- lookup_tabl(7,1,1) = 2.26019E-14
- lookup_tabl(7,1,2) = 3.66798E-12
- lookup_tabl(7,2,1) = 2.24435E-14
- lookup_tabl(7,2,2) = 3.66540E-12
- lookup_tabl(7,3,1) = 2.23254E-14
- lookup_tabl(7,3,2) = 3.66173E-12
- lookup_tabl(7,4,1) = 2.20496E-14
- lookup_tabl(7,4,2) = 3.65796E-12
-
- lookup_tabl(8,1,1) = 4.41983E-13
- lookup_tabl(8,1,2) = 7.50091E-11
- lookup_tabl(8,2,1) = 3.93335E-13
- lookup_tabl(8,2,2) = 6.79097E-11
- lookup_tabl(8,3,1) = 3.45569E-13
- lookup_tabl(8,3,2) = 6.07845E-11
- lookup_tabl(8,4,1) = 2.96971E-13
- lookup_tabl(8,4,2) = 5.36085E-11
-
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- AOD_wfa(i,k,j) = 0.
- AOD_ifa(i,k,j) = 0.
- END DO
- END DO
- END DO
-
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- rhoa = p_phy(i,k,j)/(287.*t_phy(i,k,j))
- t_idx = MAX(1, MIN(nint(10.999-0.0333*t_phy(i,k,j)),4))
- qvsat = rslf(p_phy(i,k,j),t_phy(i,k,j))
- RH = MIN(99.1, MAX(10.1, qvapor(i,k,j)/qvsat*100.))
-
- !..Get the index for the RH array element
-
- if (RH .lt. 60) then
- RH_idx1 = 1
- RH_idx2 = 2
- elseif (RH .ge. 60 .AND. RH.lt.80) then
- a_RH = 0.1
- b_RH = -4
- RH_idx = nint(a_RH*RH+b_RH)
- rh_d = rh-rh_arr(rh_idx)
- if (rh_d .lt. 0) then
- RH_idx1 = RH_idx-1
- RH_idx2 = RH_idx
- else
- RH_idx1 = RH_idx
- RH_idx2 = RH_idx+1
- if (RH_idx2.gt.rind) then
- RH_idx2 = rind
- RH_idx1 = rind-1
- endif
- endif
- else
- a_RH = 0.2
- b_RH = -12.
- RH_idx = MIN(rind, nint(a_RH*RH+b_RH))
- rh_d = rh-rh_arr(rh_idx)
- if (rh_d .lt. 0) then
- RH_idx1 = RH_idx-1
- RH_idx2 = RH_idx
- else
- RH_idx1 = RH_idx
- RH_idx2 = RH_idx+1
- if (RH_idx2.gt.rind) then
- RH_idx2 = rind
- RH_idx1 = rind-1
- endif
- endif
- endif
-
- !..RH fraction to be used
-
- rh_f = MAX(0., MIN(1.0, (rh/(100-rh)-rh_arr(rh_idx1) &
- & /(100-rh_arr(rh_idx1))) &
- & /(rh_arr(rh_idx2)/(100-rh_arr(rh_idx2)) &
- & -rh_arr(rh_idx1)/(100-rh_arr(rh_idx1))) ))
-
-
- unit_bext1 = lookup_tabl(RH_idx1,t_idx,1) &
- & + (lookup_tabl(RH_idx2,t_idx,1) &
- & - lookup_tabl(RH_idx1,t_idx,1))*rh_f
- unit_bext3 = lookup_tabl(RH_idx1,t_idx,2) &
- & + (lookup_tabl(RH_idx2,t_idx,2) &
- & - lookup_tabl(RH_idx1,t_idx,2))*rh_f
-
- ntemp = MAX(1., MIN(99999.E6, nwfa(i,k,j)))
- AOD_wfa(i,k,j) = unit_bext1*ntemp*dz8w(i,k,j)*rhoa
-
- ntemp = MAX(0.01, MIN(9999.E6, nifa(i,k,j)))
- AOD_ifa(i,k,j) = unit_bext3*ntemp*dz8w(i,k,j)*rhoa
-
- END DO
- END DO
- END DO
-
- DO j=jts,jte
- DO k=kts,kte
- DO i=its,ite
- taod5503d(i,k,j) = MAX(1.E-3, aod_wfa(i,k,j) + aod_ifa(i,k,j))
- END DO
- END DO
- END DO
-
- END SUBROUTINE gt_aod
-
-!+---+-----------------------------------------------------------------+
-
-END MODULE module_radiation_driver
diff --git a/UTIL/wrfcmaq_twoway_coupler/phys/module_sf_noahdrv.F b/UTIL/wrfcmaq_twoway_coupler/phys/module_sf_noahdrv.F
deleted file mode 100644
index c23ddb0d8b..0000000000
--- a/UTIL/wrfcmaq_twoway_coupler/phys/module_sf_noahdrv.F
+++ /dev/null
@@ -1,5272 +0,0 @@
-MODULE module_sf_noahdrv
-
-!-------------------------------
- USE module_sf_noahlsm, only: SFLX, XLF, XLV, CP, R_D, RHOWATER, NATURAL, SHDTBL, LUTYPE, SLTYPE, STBOLT, &
- & KARMAN, LUCATS, NROTBL, RSTBL, RGLTBL, HSTBL, SNUPTBL, MAXALB, LAIMINTBL, &
- & LAIMAXTBL, Z0MINTBL, Z0MAXTBL, ALBEDOMINTBL, ALBEDOMAXTBL, EMISSMINTBL, &
- & EMISSMAXTBL, TOPT_DATA, CMCMAX_DATA, CFACTR_DATA, RSMAX_DATA, BARE, NLUS, &
- & SLCATS, BB, DRYSMC, F11, MAXSMC, REFSMC, SATPSI, SATDK, SATDW, WLTSMC, QTZ, &
- & NSLTYPE, SLPCATS, SLOPE_DATA, SBETA_DATA, FXEXP_DATA, CSOIL_DATA, &
- & SALP_DATA, REFDK_DATA, REFKDT_DATA, FRZK_DATA, ZBOT_DATA, CZIL_DATA, &
- & SMLOW_DATA, SMHIGH_DATA, LVCOEF_DATA, NSLOPE, &
- & FRH2O,ZTOPVTBL,ZBOTVTBL, &
- & LCZ_1,LCZ_2,LCZ_3,LCZ_4,LCZ_5,LCZ_6,LCZ_7,LCZ_8,LCZ_9,LCZ_10,LCZ_11
- USE module_sf_urban, only: urban, oasis, IRI_SCHEME
- USE module_sf_noahlsm_glacial_only, only: sflx_glacial
- USE module_sf_bep, only: bep
- USE module_sf_bep_bem, only: bep_bem
-#if defined(mpas)
-use mpas_atmphys_date_time, only: cal_mon_day
-use mpas_atmphys_utilities, only: physics_error_fatal
-#define FATAL_ERROR(M) call physics_error_fatal( M )
-#else
- use module_ra_gfdleta, only: cal_mon_day
- use module_wrf_error
-#define FATAL_ERROR(M) call wrf_error_fatal( M )
-#endif
-#if ( WRF_CHEM == 1 )
- USE module_data_gocart_dust
-#endif
-!-------------------------------
-
-!
-CONTAINS
-!
-!----------------------------------------------------------------
-! Urban related variable are added to arguments - urban
-!----------------------------------------------------------------
- SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, &
- HFX,QFX,LH,GRDFLX, QGH,GSW,SWDOWN,SWDDIR,SWDDIF,&
- GLW,SMSTAV,SMSTOT, &
- SFCRUNOFF, UDRUNOFF,IVGTYP,ISLTYP,ISURBAN,ISICE,VEGFRA, &
- ALBEDO,ALBBCK,ZNT,Z0,TMN,XLAND,XICE,EMISS,EMBCK, &
- SNOWC,QSFC,RAINBL,MMINLU, &
- num_soil_layers,DT,DZS,ITIMESTEP, &
- SMOIS,TSLB,SNOW,CANWAT, &
- CHS,CHS2,CQS2,CPM,ROVCP,SR,chklowq,lai,qz0, & !H
- myj,frpcpn, &
- SH2O,SNOWH, & !H
- U_PHY,V_PHY, & !I
- SNOALB,SHDMIN,SHDMAX, & !I
- SNOTIME, & !?
- ACSNOM,ACSNOW, & !O
- SNOPCX, & !O
- POTEVP, & !O
- SMCREL, & !O
- XICE_THRESHOLD, &
- RDLAI2D,USEMONALB, &
- RIB, & !?
- NOAHRES,opt_thcnd, &
-! Noah UA changes
- ua_phys,flx4_2d,fvb_2d,fbur_2d,fgsn_2d, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte, &
- sf_urban_physics, &
- CMR_SFCDIF,CHR_SFCDIF,CMC_SFCDIF,CHC_SFCDIF, &
- CMGR_SFCDIF,CHGR_SFCDIF, &
-!Optional Urban
- TR_URB2D,TB_URB2D,TG_URB2D,TC_URB2D,QC_URB2D, & !H urban
- UC_URB2D, & !H urban
- XXXR_URB2D,XXXB_URB2D,XXXG_URB2D,XXXC_URB2D, & !H urban
- TRL_URB3D,TBL_URB3D,TGL_URB3D, & !H urban
- SH_URB2D,LH_URB2D,G_URB2D,RN_URB2D,TS_URB2D, & !H urban
- PSIM_URB2D,PSIH_URB2D,U10_URB2D,V10_URB2D, & !O urban
- GZ1OZ0_URB2D, AKMS_URB2D, & !O urban
- TH2_URB2D,Q2_URB2D, UST_URB2D, & !O urban
- DECLIN_URB,COSZ_URB2D,OMG_URB2D, & !I urban
- XLAT_URB2D, & !I urban
- num_roof_layers, num_wall_layers, & !I urban
- num_road_layers, DZR, DZB, DZG, & !I urban
- CMCR_URB2D,TGR_URB2D,TGRL_URB3D,SMR_URB3D, & !H urban
- DRELR_URB2D,DRELB_URB2D,DRELG_URB2D, & !H urban
- FLXHUMR_URB2D,FLXHUMB_URB2D,FLXHUMG_URB2D, & !H urban
- julian, julyr, & !H urban
- FRC_URB2D,UTYPE_URB2D, & !O
- num_urban_ndm, & !I multi-layer urban
- urban_map_zrd, & !I multi-layer urban
- urban_map_zwd, & !I multi-layer urban
- urban_map_gd, & !I multi-layer urban
- urban_map_zd, & !I multi-layer urban
- urban_map_zdf, & !I multi-layer urban
- urban_map_bd, & !I multi-layer urban
- urban_map_wd, & !I multi-layer urban
- urban_map_gbd, & !I multi-layer urban
- urban_map_fbd, & !I multi-layer urban
- urban_map_zgrd, & !I multi-layer urban
- num_urban_hi, & !I multi-layer urban
- tsk_rural_bep, & !H multi-layer urban
- trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, & !H multi-layer urban
- tlev_urb3d,qlev_urb3d, & !H multi-layer urban
- tw1lev_urb3d,tw2lev_urb3d, & !H multi-layer urban
- tglev_urb3d,tflev_urb3d, & !H multi-layer urban
- sf_ac_urb3d,lf_ac_urb3d,cm_ac_urb3d, & !H multi-layer urban
- sfvent_urb3d,lfvent_urb3d, & !H multi-layer urban
- sfwin1_urb3d,sfwin2_urb3d, & !H multi-layer urban
- sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d, & !H multi-layer urban
- ep_pv_urb3d,t_pv_urb3d, & !RMS
- trv_urb4d,qr_urb4d,qgr_urb3d,tgr_urb3d, & !RMS
- drain_urb4d,draingr_urb3d,sfrv_urb3d, & !RMS
- lfrv_urb3d,dgr_urb3d,dg_urb3d,lfr_urb3d,lfg_urb3d,& !RMS
- lp_urb2d,hi_urb2d,lb_urb2d,hgt_urb2d, & !H multi-layer urban
- mh_urb2d,stdh_urb2d,lf_urb2d, & !SLUCM
- th_phy,rho,p_phy,ust, & !I multi-layer urban
- gmt,julday,xlong,xlat, & !I multi-layer urban
- a_u_bep,a_v_bep,a_t_bep,a_q_bep, & !O multi-layer urban
- a_e_bep,b_u_bep,b_v_bep, & !O multi-layer urban
- b_t_bep,b_q_bep,b_e_bep,dlg_bep, & !O multi-layer urban
- dl_u_bep,sf_bep,vl_bep,sfcheadrt,INFXSRT, soldrain & !O multi-layer urban
- ,SDA_HFX, SDA_QFX, HFX_BOTH, QFX_BOTH, QNORM, fasdas & !fasdas
- ,RC2,XLAI2 &
- ,IRR_CHAN &
- )
-
-!----------------------------------------------------------------
- IMPLICIT NONE
-!----------------------------------------------------------------
-!----------------------------------------------------------------
-! --- atmospheric (WRF generic) variables
-!-- DT time step (seconds)
-!-- DZ8W thickness of layers (m)
-!-- T3D temperature (K)
-!-- QV3D 3D water vapor mixing ratio (Kg/Kg)
-!-- P3D 3D pressure (Pa)
-!-- FLHC exchange coefficient for heat (m/s)
-!-- FLQC exchange coefficient for moisture (m/s)
-!-- PSFC surface pressure (Pa)
-!-- XLAND land mask (1 for land, 2 for water)
-!-- QGH saturated mixing ratio at 2 meter
-!-- GSW downward short wave flux at ground surface (W/m^2)
-!-- GLW downward long wave flux at ground surface (W/m^2)
-!-- History variables
-!-- CANWAT canopy moisture content (mm)
-!-- TSK surface temperature (K)
-!-- TSLB soil temp (k)
-!-- SMOIS total soil moisture content (volumetric fraction)
-!-- SH2O unfrozen soil moisture content (volumetric fraction)
-! note: frozen soil moisture (i.e., soil ice) = SMOIS - SH2O
-!-- SNOWH actual snow depth (m)
-!-- SNOW liquid water-equivalent snow depth (m)
-!-- ALBEDO time-varying surface albedo including snow effect (unitless fraction)
-!-- ALBBCK background surface albedo (unitless fraction)
-!-- CHS surface exchange coefficient for heat and moisture (m s-1);
-!-- CHS2 2m surface exchange coefficient for heat (m s-1);
-!-- CQS2 2m surface exchange coefficient for moisture (m s-1);
-! --- soil variables
-!-- num_soil_layers the number of soil layers
-!-- ZS depths of centers of soil layers (m)
-!-- DZS thicknesses of soil layers (m)
-!-- SLDPTH thickness of each soil layer (m, same as DZS)
-!-- TMN soil temperature at lower boundary (K)
-!-- SMCWLT wilting point (volumetric)
-!-- SMCDRY dry soil moisture threshold where direct evap from
-! top soil layer ends (volumetric)
-!-- SMCREF soil moisture threshold below which transpiration begins to
-! stress (volumetric)
-!-- SMCMAX porosity, i.e. saturated value of soil moisture (volumetric)
-!-- NROOT number of root layers, a function of veg type, determined
-! in subroutine redprm.
-!-- SMSTAV Soil moisture availability for evapotranspiration (
-! fraction between SMCWLT and SMCMXA)
-!-- SMSTOT Total soil moisture content frozen+unfrozen) in the soil column (mm)
-! --- snow variables
-!-- SNOWC fraction snow coverage (0-1.0)
-! --- vegetation variables
-!-- SNOALB upper bound on maximum albedo over deep snow
-!-- SHDMIN minimum areal fractional coverage of annual green vegetation
-!-- SHDMAX maximum areal fractional coverage of annual green vegetation
-!-- XLAI leaf area index (dimensionless)
-!-- XLAI2 leaf area index (same as XLAI) passed to output (dimensionless)
-!-- Z0BRD Background fixed roughness length (M)
-!-- Z0 Background vroughness length (M) as function
-!-- ZNT Time varying roughness length (M) as function
-!-- ALBD(IVGTPK,ISN) background albedo reading from a table
-! --- LSM output
-!-- HFX upward heat flux at the surface (W/m^2)
-!-- QFX upward moisture flux at the surface (kg/m^2/s)
-!-- LH upward moisture flux at the surface (W m-2)
-!-- GRDFLX(I,J) ground heat flux (W m-2)
-!-- FDOWN radiation forcing at the surface (W m-2) = SOLDN*(1-alb)+LWDN
-!----------------------------------------------------------------------------
-!-- EC canopy water evaporation ((W m-2)
-!-- EDIR direct soil evaporation (W m-2)
-!-- ET plant transpiration from a particular root layer (W m-2)
-!-- ETT total plant transpiration (W m-2)
-!-- ESNOW sublimation from (or deposition to if <0) snowpack (W m-2)
-!-- DRIP through-fall of precip and/or dew in excess of canopy
-! water-holding capacity (m)
-!-- DEW dewfall (or frostfall for t<273.15) (M)
-!-- SMAV Soil Moisture Availability for each layer, as a fraction
-! between SMCWLT and SMCMAX (dimensionless fraction)
-! ----------------------------------------------------------------------
-!-- BETA ratio of actual/potential evap (dimensionless)
-!-- ETP potential evaporation (W m-2)
-! ----------------------------------------------------------------------
-!-- FLX1 precip-snow sfc (W m-2)
-!-- FLX2 freezing rain latent heat flux (W m-2)
-!-- FLX3 phase-change heat flux from snowmelt (W m-2)
-! ----------------------------------------------------------------------
-!-- ACSNOM snow melt (mm) (water equivalent)
-!-- ACSNOW accumulated snow fall (mm) (water equivalent)
-!-- SNOPCX snow phase change heat flux (W/m^2)
-!-- POTEVP accumulated potential evaporation (m)
-!-- RIB Documentation needed!!!
-! ----------------------------------------------------------------------
-!-- RUNOFF1 surface runoff (m s-1), not infiltrating the surface
-!-- RUNOFF2 subsurface runoff (m s-1), drainage out bottom of last
-! soil layer (baseflow)
-! important note: here RUNOFF2 is actually the sum of RUNOFF2 and RUNOFF3
-!-- RUNOFF3 numerical trunctation in excess of porosity (smcmax)
-! for a given soil layer at the end of a time step (m s-1).
-!SFCRUNOFF Surface Runoff (mm)
-!UDRUNOFF Total Underground Runoff (mm), which is the sum of RUNOFF2 and RUNOFF3
-! ----------------------------------------------------------------------
-!-- RC canopy resistance (s m-1)
-!-- RC2 canopy resistance (same as RC) passed to output
-!-- PC plant coefficient (unitless fraction, 0-1) where PC*ETP = actual transp
-!-- RSMIN minimum canopy resistance (s m-1)
-!-- RCS incoming solar rc factor (dimensionless)
-!-- RCT air temperature rc factor (dimensionless)
-!-- RCQ atmos vapor pressure deficit rc factor (dimensionless)
-!-- RCSOIL soil moisture rc factor (dimensionless)
-
-!-- EMISS surface emissivity (between 0 and 1)
-!-- EMBCK Background surface emissivity (between 0 and 1)
-
-!-- ROVCP R/CP
-! (R_d/R_v) (dimensionless)
-!-- ids start index for i in domain
-!-- ide end index for i in domain
-!-- jds start index for j in domain
-!-- jde end index for j in domain
-!-- kds start index for k in domain
-!-- kde end index for k in domain
-!-- ims start index for i in memory
-!-- ime end index for i in memory
-!-- jms start index for j in memory
-!-- jme end index for j in memory
-!-- kms start index for k in memory
-!-- kme end index for k in memory
-!-- its start index for i in tile
-!-- ite end index for i in tile
-!-- jts start index for j in tile
-!-- jte end index for j in tile
-!-- kts start index for k in tile
-!-- kte end index for k in tile
-!
-!-- SR fraction of frozen precip (0.0 to 1.0)
-!----------------------------------------------------------------
-
-! IN only
-
- INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte
-
- INTEGER, INTENT(IN ) :: sf_urban_physics !urban
- INTEGER, INTENT(IN ) :: isurban
- INTEGER, INTENT(IN ) :: isice
- INTEGER, INTENT(IN ) :: julian, julyr !urban
-
-!added by Wei Yu for routing
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(INOUT) :: sfcheadrt,INFXSRT,soldrain
- real :: etpnd1
-!end added
-
-
-
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(IN ) :: TMN, &
- XLAND, &
- XICE, &
- VEGFRA, &
- SHDMIN, &
- SHDMAX, &
- SNOALB, &
- GSW, &
- SWDOWN, & !added 10 jan 2007
- GLW, &
- RAINBL, &
- EMBCK, &
- SR, &
- SWDDIR, &
- SWDDIF
-
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(INOUT) :: ALBBCK, &
- Z0
- CHARACTER(LEN=*), INTENT(IN ) :: MMINLU
-
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
- INTENT(IN ) :: QV3D, &
- p8w3D, &
- DZ8W, &
- T3D
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(IN ) :: QGH, &
- CPM
-
- INTEGER, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(IN ) :: IVGTYP, &
- ISLTYP
-
- INTEGER, INTENT(IN) :: num_soil_layers,ITIMESTEP
-
- REAL, INTENT(IN ) :: DT,ROVCP
-
- REAL, DIMENSION(1:num_soil_layers), INTENT(IN)::DZS
-
-! IN and OUT
-
- REAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), &
- INTENT(INOUT) :: SMOIS, & ! total soil moisture
- SH2O, & ! new soil liquid
- TSLB ! TSLB STEMP
-
- REAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), &
- INTENT(OUT) :: SMCREL
-
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(INOUT) :: TSK, & !was TGB (temperature)
- HFX, &
- QFX, &
- LH, &
- GRDFLX, &
- QSFC,&
- CQS2,&
- CHS, &
- CHS2,&
- SNOW, &
- SNOWC, &
- SNOWH, & !new
- CANWAT, &
- SMSTAV, &
- SMSTOT, &
- SFCRUNOFF, &
- UDRUNOFF, &
- ACSNOM, &
- ACSNOW, &
- SNOTIME, &
- SNOPCX, &
- EMISS, &
- RIB, &
- POTEVP, &
- ALBEDO, &
- ZNT
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(OUT) :: NOAHRES
- INTEGER, INTENT(IN) :: OPT_THCND
-
-! Noah UA changes
- LOGICAL, INTENT(IN) :: UA_PHYS
- REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: FLX4_2D,FVB_2D,FBUR_2D,FGSN_2D
- REAL :: FLX4,FVB,FBUR,FGSN
-
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(OUT) :: CHKLOWQ
- REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LAI
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: QZ0
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: RC2, XLAI2
-
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMR_SFCDIF
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHR_SFCDIF
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMGR_SFCDIF
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHGR_SFCDIF
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMC_SFCDIF
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHC_SFCDIF
-! Local variables (moved here from driver to make routine thread safe, 20031007 jm)
-
- REAL, DIMENSION(1:num_soil_layers) :: ET
-
- REAL, DIMENSION(1:num_soil_layers) :: SMAV
-
- REAL :: BETA, ETP, SSOIL,EC, EDIR, ESNOW, ETT, &
- FLX1,FLX2,FLX3, DRIP,DEW,FDOWN,RC,PC,RSMIN,XLAI, &
-! RCS,RCT,RCQ,RCSOIL
- RCS,RCT,RCQ,RCSOIL,FFROZP
-
- LOGICAL, INTENT(IN ) :: myj,frpcpn
-
-! DECLARATIONS - LOGICAL
-! ----------------------------------------------------------------------
- LOGICAL, PARAMETER :: LOCAL=.false.
- LOGICAL :: FRZGRA, SNOWNG
-
- LOGICAL :: IPRINT
-
-! ----------------------------------------------------------------------
-! DECLARATIONS - INTEGER
-! ----------------------------------------------------------------------
- INTEGER :: I,J, ICE,NSOIL,SLOPETYP,SOILTYP,VEGTYP
- INTEGER :: NROOT
- INTEGER :: KZ ,K
- INTEGER :: NS
-! ----------------------------------------------------------------------
-! DECLARATIONS - REAL
-! ----------------------------------------------------------------------
-
- REAL :: SHMIN,SHMAX,DQSDT2,LWDN,PRCP,PRCPRAIN, &
- Q2SAT,Q2SATI,SFCPRS,SFCSPD,SFCTMP,SHDFAC,SNOALB1, &
- SOLDN,TBOT,ZLVL, Q2K,ALBBRD, ALBEDOK, ETA, ETA_KINEMATIC, &
- EMBRD, &
- Z0K,RUNOFF1,RUNOFF2,RUNOFF3,SHEAT,SOLNET,E2SAT,SFCTSNO, &
-! mek, WRF testing, expanded diagnostics
- SOLUP,LWUP,RNET,RES,Q1SFC,TAIRV,SATFLG
-! MEK MAY 2007
- REAL :: FDTLIW
-! MEK JUL2007 for pot. evap.
- REAL :: RIBB
- REAL :: FDTW
-
- REAL :: EMISSI
-
- REAL :: SNCOVR,SNEQV,SNOWHK,CMC, CHK,TH2
-
- REAL :: SMCDRY,SMCMAX,SMCREF,SMCWLT,SNOMLT,SOILM,SOILW,Q1,T1
- REAL :: SNOTIME1 ! LSTSNW1 INITIAL NUMBER OF TIMESTEPS SINCE LAST SNOWFALL
-
- REAL :: DUMMY,Z0BRD
-!
- REAL :: COSZ, SOLARDIRECT
-!
- REAL, DIMENSION(1:num_soil_layers):: SLDPTH, STC,SMC,SWC
-!
- REAL, DIMENSION(1:num_soil_layers) :: ZSOIL, RTDIS
- REAL, PARAMETER :: TRESH=.95E0, A2=17.67,A3=273.15,A4=29.65, &
- T0=273.16E0, ELWV=2.50E6, A23M4=A2*(A3-A4)
-! MEK MAY 2007
- REAL, PARAMETER :: ROW=1.E3,ELIW=XLF,ROWLIW=ROW*ELIW
-
-! ----------------------------------------------------------------------
-! DECLARATIONS START - urban
-! ----------------------------------------------------------------------
-
-! input variables surface_driver --> lsm
- INTEGER, INTENT(IN) :: num_roof_layers
- INTEGER, INTENT(IN) :: num_wall_layers
- INTEGER, INTENT(IN) :: num_road_layers
- REAL, OPTIONAL, DIMENSION(1:num_roof_layers), INTENT(IN) :: DZR
- REAL, OPTIONAL, DIMENSION(1:num_wall_layers), INTENT(IN) :: DZB
- REAL, OPTIONAL, DIMENSION(1:num_road_layers), INTENT(IN) :: DZG
- REAL, OPTIONAL, INTENT(IN) :: DECLIN_URB
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: COSZ_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: OMG_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: XLAT_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: U_PHY
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: V_PHY
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: TH_PHY
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: P_PHY
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: RHO
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UST
-
- LOGICAL, intent(in) :: rdlai2d
- LOGICAL, intent(in) :: USEMONALB
-
-! input variables lsm --> urban
- INTEGER :: UTYPE_URB ! urban type [urban=1, suburban=2, rural=3]
- REAL :: TA_URB ! potential temp at 1st atmospheric level [K]
- REAL :: QA_URB ! mixing ratio at 1st atmospheric level [kg/kg]
- REAL :: UA_URB ! wind speed at 1st atmospheric level [m/s]
- REAL :: U1_URB ! u at 1st atmospheric level [m/s]
- REAL :: V1_URB ! v at 1st atmospheric level [m/s]
- REAL :: SSG_URB ! downward total short wave radiation [W/m/m]
- REAL :: LLG_URB ! downward long wave radiation [W/m/m]
- REAL :: RAIN_URB ! precipitation [mm/h]
- REAL :: RHOO_URB ! air density [kg/m^3]
- REAL :: ZA_URB ! first atmospheric level [m]
- REAL :: DELT_URB ! time step [s]
- REAL :: SSGD_URB ! downward direct short wave radiation [W/m/m]
- REAL :: SSGQ_URB ! downward diffuse short wave radiation [W/m/m]
- REAL :: XLAT_URB ! latitude [deg]
- REAL :: COSZ_URB ! cosz
- REAL :: OMG_URB ! hour angle
- REAL :: ZNT_URB ! roughness length [m]
- REAL :: TR_URB
- REAL :: TB_URB
- REAL :: TG_URB
- REAL :: TC_URB
- REAL :: QC_URB
- REAL :: UC_URB
- REAL :: XXXR_URB
- REAL :: XXXB_URB
- REAL :: XXXG_URB
- REAL :: XXXC_URB
- REAL, DIMENSION(1:num_roof_layers) :: TRL_URB ! roof layer temp [K]
- REAL, DIMENSION(1:num_wall_layers) :: TBL_URB ! wall layer temp [K]
- REAL, DIMENSION(1:num_road_layers) :: TGL_URB ! road layer temp [K]
- LOGICAL :: LSOLAR_URB
-
-!===Yang,2014/10/08,hydrological variable for single layer UCM===
- INTEGER :: jmonth, jday, tloc
- INTEGER :: IRIOPTION, USOIL, DSOIL
- REAL :: AOASIS, OMG
- REAL :: DRELR_URB
- REAL :: DRELB_URB
- REAL :: DRELG_URB
- REAL :: FLXHUMR_URB
- REAL :: FLXHUMB_URB
- REAL :: FLXHUMG_URB
- REAL :: CMCR_URB
- REAL :: TGR_URB
- REAL, DIMENSION(1:num_roof_layers) :: SMR_URB ! green roof layer moisture
- REAL, DIMENSION(1:num_roof_layers) :: TGRL_URB ! green roof layer temp [K]
-
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELR_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELB_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELG_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMR_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMB_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMG_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMCR_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TGR_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: TGRL_URB3D
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: SMR_URB3D
-
-
-! state variable surface_driver <--> lsm <--> urban
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TR_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TB_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TG_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TC_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: QC_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UC_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXR_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXB_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXG_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXC_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SH_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LH_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: G_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: RN_URB2D
-!
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TS_URB2D
-
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: TRL_URB3D
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_wall_layers, jms:jme ), INTENT(INOUT) :: TBL_URB3D
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_road_layers, jms:jme ), INTENT(INOUT) :: TGL_URB3D
-
-! output variable lsm --> surface_driver
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: PSIM_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: PSIH_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: GZ1OZ0_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: U10_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: V10_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: TH2_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: Q2_URB2D
-!
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: AKMS_URB2D
-!
- REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: UST_URB2D
- REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: FRC_URB2D
- INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: UTYPE_URB2D
-
-
-! output variables urban --> lsm
- REAL :: TS_URB ! surface radiative temperature [K]
- REAL :: QS_URB ! surface humidity [-]
- REAL :: SH_URB ! sensible heat flux [W/m/m]
- REAL :: LH_URB ! latent heat flux [W/m/m]
- REAL :: LH_KINEMATIC_URB ! latent heat flux, kinetic [kg/m/m/s]
- REAL :: SW_URB ! upward short wave radiation flux [W/m/m]
- REAL :: ALB_URB ! time-varying albedo [fraction]
- REAL :: LW_URB ! upward long wave radiation flux [W/m/m]
- REAL :: G_URB ! heat flux into the ground [W/m/m]
- REAL :: RN_URB ! net radiation [W/m/m]
- REAL :: PSIM_URB ! shear f for momentum [-]
- REAL :: PSIH_URB ! shear f for heat [-]
- REAL :: GZ1OZ0_URB ! shear f for heat [-]
- REAL :: U10_URB ! wind u component at 10 m [m/s]
- REAL :: V10_URB ! wind v component at 10 m [m/s]
- REAL :: TH2_URB ! potential temperature at 2 m [K]
- REAL :: Q2_URB ! humidity at 2 m [-]
- REAL :: CHS_URB
- REAL :: CHS2_URB
- REAL :: UST_URB
-! NUDAPT Parameters urban --> lam
- REAL :: mh_urb
- REAL :: stdh_urb
- REAL :: lp_urb
- REAL :: hgt_urb
- REAL, DIMENSION(4) :: lf_urb
-! Variables for multi-layer UCM (Martilli et al. 2002)
- REAL, OPTIONAL, INTENT(IN ) :: GMT
- INTEGER, OPTIONAL, INTENT(IN ) :: JULDAY
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) ::XLAT, XLONG
- INTEGER, INTENT(IN ) :: num_urban_ndm
- INTEGER, INTENT(IN ) :: urban_map_zrd
- INTEGER, INTENT(IN ) :: urban_map_zwd
- INTEGER, INTENT(IN ) :: urban_map_gd
- INTEGER, INTENT(IN ) :: urban_map_zd
- INTEGER, INTENT(IN ) :: urban_map_zdf
- INTEGER, INTENT(IN ) :: urban_map_bd
- INTEGER, INTENT(IN ) :: urban_map_wd
- INTEGER, INTENT(IN ) :: urban_map_gbd
- INTEGER, INTENT(IN ) :: urban_map_fbd
- INTEGER, INTENT(IN ) :: urban_map_zgrd
- INTEGER, INTENT(IN ) :: NUM_URBAN_HI
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: tsk_rural_bep
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zrd, jms:jme ), INTENT(INOUT) :: trb_urb4d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zwd, jms:jme ), INTENT(INOUT) :: tw1_urb4d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zwd, jms:jme ), INTENT(INOUT) :: tw2_urb4d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_gd , jms:jme ), INTENT(INOUT) :: tgb_urb4d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_bd , jms:jme ), INTENT(INOUT) :: tlev_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_bd , jms:jme ), INTENT(INOUT) :: qlev_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: tw1lev_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: tw2lev_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_gbd, jms:jme ), INTENT(INOUT) :: tglev_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_fbd, jms:jme ), INTENT(INOUT) :: tflev_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lf_ac_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sf_ac_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: cm_ac_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sfvent_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lfvent_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: sfwin1_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: sfwin2_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zd , jms:jme ), INTENT(INOUT) :: sfw1_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zd , jms:jme ), INTENT(INOUT) :: sfw2_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: sfr_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ), INTENT(INOUT) :: sfg_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ep_pv_urb3d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: t_pv_urb3d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zgrd, jms:jme ),INTENT(INOUT) :: trv_urb4d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zgrd, jms:jme ),INTENT(INOUT) :: qr_urb4d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime,jms:jme ), INTENT(INOUT) :: qgr_urb3d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime,jms:jme ), INTENT(INOUT) :: tgr_urb3d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: drain_urb4d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: draingr_urb3d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: sfrv_urb3d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: lfrv_urb3d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: dgr_urb3d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ),INTENT(INOUT) :: dg_urb3d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: lfr_urb3d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ),INTENT(INOUT) :: lfg_urb3d !GRZ
-
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_hi, jms:jme ), INTENT(IN) :: hi_urb2d
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: lp_urb2d
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: lb_urb2d
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: hgt_urb2d
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: mh_urb2d
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: stdh_urb2d
- REAL, OPTIONAL, DIMENSION( ims:ime, 4, jms:jme ), INTENT(IN) :: lf_urb2d
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_u_bep !Implicit momemtum component X-direction
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_v_bep !Implicit momemtum component Y-direction
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_t_bep !Implicit component pot. temperature
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_q_bep !Implicit momemtum component X-direction
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_e_bep !Implicit component TKE
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_u_bep !Explicit momentum component X-direction
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_v_bep !Explicit momentum component Y-direction
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_t_bep !Explicit component pot. temperature
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_q_bep !Implicit momemtum component Y-direction
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_e_bep !Explicit component TKE
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::vl_bep !Fraction air volume in grid cell
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::dlg_bep !Height above ground
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::sf_bep !Fraction air at the face of grid cell
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::dl_u_bep !Length scale
-
-! Local variables for multi-layer UCM (Martilli et al. 2002)
- REAL, DIMENSION( its:ite, jts:jte ) :: HFX_RURAL,LH_RURAL,GRDFLX_RURAL ! ,RN_RURAL
- REAL, DIMENSION( its:ite, jts:jte ) :: QFX_RURAL ! ,QSFC_RURAL,UMOM_RURAL,VMOM_RURAL
- REAL, DIMENSION( its:ite, jts:jte ) :: ALB_RURAL,EMISS_RURAL,TSK_RURAL ! ,UST_RURAL
-! REAL, DIMENSION( ims:ime, jms:jme ) :: QSFC_URB
- REAL, DIMENSION( its:ite, jts:jte ) :: HFX_URB,UMOM_URB,VMOM_URB
- REAL, DIMENSION( its:ite, jts:jte ) :: QFX_URB
-! REAL, DIMENSION( ims:ime, jms:jme ) :: ALBEDO_URB,EMISS_URB,UMOM,VMOM,UST
- REAL, DIMENSION(its:ite,jts:jte) ::EMISS_URB
- REAL, DIMENSION(its:ite,jts:jte) :: RL_UP_URB
- REAL, DIMENSION(its:ite,jts:jte) ::RS_ABS_URB
- REAL, DIMENSION(its:ite,jts:jte) ::GRDFLX_URB
- REAL :: SIGMA_SB,RL_UP_RURAL,RL_UP_TOT,RS_ABS_TOT,UMOM,VMOM
- REAL :: CMR_URB, CHR_URB, CMC_URB, CHC_URB, CMGR_URB, CHGR_URB
- REAL :: frc_urb,lb_urb
- REAL :: check
-! ----------------------------------------------------------------------
-! DECLARATIONS END - urban
-! ----------------------------------------------------------------------
-
- REAL, PARAMETER :: CAPA=R_D/CP
- REAL :: APELM,APES,SFCTH2,PSFC
- real, intent(in) :: xice_threshold
- character(len=80) :: message_text
-!
-! FASDAS
-!
- REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, &
- INTENT(INOUT) :: SDA_HFX, SDA_QFX, HFX_BOTH, QFX_BOTH, QNORM
- INTEGER, INTENT(IN ) :: fasdas
-! local vars
- REAL :: XSDA_HFX, XSDA_QFX, XQNORM
- REAL :: HFX_PHY, QFX_PHY
- REAL :: DZQ
- REAL :: HCPCT_FASDAS
-
- REAL,OPTIONAL,INTENT(IN),DIMENSION( ims:ime, jms:jme ) :: IRR_CHAN
- REAL :: IRRIGATION_CHANNEL
- IRRIGATION_CHANNEL =0.0
- HFX_PHY = 0.0 ! initialize
- QFX_PHY = 0.0
- XQNORM = 0.0
- XSDA_HFX = 0.0
- XSDA_QFX = 0.0
-!
-! END FASDAS
-!
- FLX4 = 0.0 !BSINGH - Initialized to 0.0
- FVB = 0.0 !BSINGH - Initialized to 0.0
- FBUR = 0.0 !BSINGH - Initialized to 0.0
- FGSN = 0.0 !BSINGH - Initialized to 0.0
- SOILW = 0.0 !BSINGH - Initialized to 0.0
-
- sigma_sb=5.67e-08
-
-! MEK MAY 2007
- FDTLIW=DT/ROWLIW
-! MEK JUL2007
- FDTW=DT/(XLV*RHOWATER)
-! debug printout
- IPRINT=.false.
-
-! SLOPETYP=2
- SLOPETYP=1
-! SHDMIN=0.00
-
-
- NSOIL=num_soil_layers
-
- DO NS=1,NSOIL
- SLDPTH(NS)=DZS(NS)
- ENDDO
-
- JLOOP : DO J=jts,jte
-
- IF(ITIMESTEP.EQ.1)THEN
- DO 50 I=its,ite
-!*** initialize soil conditions for IHOP 31 May case
-! IF((XLAND(I,J)-1.5) < 0.)THEN
-! if (I==108.and.j==85) then
-! DO NS=1,NSOIL
-! SMOIS(I,NS,J)=0.10
-! SH2O(I,NS,J)=0.10
-! enddo
-! endif
-! ENDIF
-
-!*** SET ZERO-VALUE FOR SOME OUTPUT DIAGNOSTIC ARRAYS
- IF((XLAND(I,J)-1.5).GE.0.)THEN
-! check sea-ice point
-#if 0
- IF( XICE(I,J).GE. XICE_THRESHOLD .and. IPRINT ) PRINT*, ' sea-ice at water point, I=',I,'J=',J
-#endif
-!*** Open Water Case
- SMSTAV(I,J)=1.0
- SMSTOT(I,J)=1.0
- DO NS=1,NSOIL
- SMOIS(I,NS,J)=1.0
- TSLB(I,NS,J)=273.16 !STEMP
- SMCREL(I,NS,J)=1.0
- ENDDO
- ELSE
- IF ( XICE(I,J) .GE. XICE_THRESHOLD ) THEN
-!*** SEA-ICE CASE
- SMSTAV(I,J)=1.0
- SMSTOT(I,J)=1.0
- DO NS=1,NSOIL
- SMOIS(I,NS,J)=1.0
- SMCREL(I,NS,J)=1.0
- ENDDO
- ENDIF
- ENDIF
-!
- 50 CONTINUE
- ENDIF ! end of initialization over ocean
-
-!-----------------------------------------------------------------------
- ILOOP : DO I=its,ite
-! surface pressure
- PSFC=P8w3D(i,1,j)
-! pressure in middle of lowest layer
- SFCPRS=(P8W3D(I,KTS+1,j)+P8W3D(i,KTS,j))*0.5
-! convert from mixing ratio to specific humidity
- Q2K=QV3D(i,1,j)/(1.0+QV3D(i,1,j))
-!
-! Q2SAT=QGH(I,j)
- Q2SAT=QGH(I,J)/(1.0+QGH(I,J)) ! Q2SAT is sp humidity
-! add check on myj=.true.
-! IF((Q2K.GE.Q2SAT*TRESH).AND.Q2K.LT.QZ0(I,J))THEN
- IF((myj).AND.(Q2K.GE.Q2SAT*TRESH).AND.Q2K.LT.QZ0(I,J))THEN
- SATFLG=0.
- CHKLOWQ(I,J)=0.
- ELSE
- SATFLG=1.0
- CHKLOWQ(I,J)=1.
- ENDIF
-
- SFCTMP=T3D(i,1,j)
- ZLVL=0.5*DZ8W(i,1,j)
-
-! TH2=SFCTMP+(0.0097545*ZLVL)
-! calculate SFCTH2 via Exner function vs lapse-rate (above)
- APES=(1.E5/PSFC)**CAPA
- APELM=(1.E5/SFCPRS)**CAPA
- SFCTH2=SFCTMP*APELM
- TH2=SFCTH2/APES
-!
- EMISSI = EMISS(I,J)
- LWDN=GLW(I,J)*EMISSI
-! SOLDN is total incoming solar
- SOLDN=SWDOWN(I,J)
-! GSW is net downward solar
-! SOLNET=GSW(I,J)
-! use mid-day albedo to determine net downward solar (no solar zenith angle correction)
- SOLNET=SOLDN*(1.-ALBEDO(I,J))
- PRCP=RAINBL(i,j)/DT
- IF(PRESENT(IRR_CHAN)) THEN
- IF(IRR_CHAN(i,j).NE.0) THEN
- IRRIGATION_CHANNEL=IRR_CHAN(i,j)/DT
- ELSE
- IRRIGATION_CHANNEL=0.
- END IF
- ENDIF
- VEGTYP=IVGTYP(I,J)
- SOILTYP=ISLTYP(I,J)
- SHDFAC=VEGFRA(I,J)/100.
- T1=TSK(I,J)
- CHK=CHS(I,J)
- SHMIN=SHDMIN(I,J)/100. !NEW
- SHMAX=SHDMAX(I,J)/100. !NEW
-! convert snow water equivalent from mm to meter
- SNEQV=SNOW(I,J)*0.001
-! snow depth in meters
- SNOWHK=SNOWH(I,J)
- SNCOVR=SNOWC(I,J)
-
-! if "SR" present, set frac of frozen precip ("FFROZP") = snow-ratio ("SR", range:0-1)
-! SR from e.g. Ferrier microphysics
-! otherwise define from 1st atmos level temperature
- IF(FRPCPN) THEN
- FFROZP=SR(I,J)
- ELSE
- IF (SFCTMP <= 273.15) THEN
- FFROZP = 1.0
- ELSE
- FFROZP = 0.0
- ENDIF
- ENDIF
-!***
- IF((XLAND(I,J)-1.5).GE.0.)THEN ! begining of land/sea if block
-! Open water points
- TSK_RURAL(I,J)=TSK(I,J)
- HFX_RURAL(I,J)=HFX(I,J)
- QFX_RURAL(I,J)=QFX(I,J)
- LH_RURAL(I,J)=LH(I,J)
- EMISS_RURAL(I,J)=EMISS(I,J)
- GRDFLX_RURAL(I,J)=GRDFLX(I,J)
-
- ELSE
-! Land or sea-ice case
-
- IF (XICE(I,J) >= XICE_THRESHOLD) THEN
- ! Sea-ice point
- ICE = 1
- ELSE IF ( VEGTYP == ISICE ) THEN
- ! Land-ice point
- ICE = -1
- ELSE
- ! Neither sea ice or land ice.
- ICE=0
- ENDIF
- DQSDT2=Q2SAT*A23M4/(SFCTMP-A4)**2
-
- IF(SNOW(I,J).GT.0.0)THEN
-! snow on surface (use ice saturation properties)
- SFCTSNO=SFCTMP
- E2SAT=611.2*EXP(6174.*(1./273.15 - 1./SFCTSNO))
- Q2SATI=0.622*E2SAT/(SFCPRS-E2SAT)
- Q2SATI=Q2SATI/(1.0+Q2SATI) ! spec. hum.
- IF (T1 .GT. 273.14) THEN
-! warm ground temps, weight the saturation between ice and water according to SNOWC
- Q2SAT=Q2SAT*(1.-SNOWC(I,J)) + Q2SATI*SNOWC(I,J)
- DQSDT2=DQSDT2*(1.-SNOWC(I,J)) + Q2SATI*6174./(SFCTSNO**2)*SNOWC(I,J)
- ELSE
-! cold ground temps, use ice saturation only
- Q2SAT=Q2SATI
- DQSDT2=Q2SATI*6174./(SFCTSNO**2)
- ENDIF
-! for snow cover fraction at 0 C, ground temp will not change, so DQSDT2 effectively zero
-! V3.8 add condition for SWDOWN to restrict condition to positive forcing (JD)
- IF(T1 .GT. 273. .AND. SNOWC(I,J) .GT. 0. .AND. SWDOWN(I,J) .GT. 10.)DQSDT2=DQSDT2*(1.-SNOWC(I,J))
- ENDIF
-
- ! Land-ice or land points use the usual deep-soil temperature.
- TBOT=TMN(I,J)
-
- IF(ISURBAN.EQ.1) THEN
-! assumes these only need to be set for USGS land data
- IF(VEGTYP.EQ.25) SHDFAC=0.0000
- IF(VEGTYP.EQ.26) SHDFAC=0.0000
- IF(VEGTYP.EQ.27) SHDFAC=0.0000
- ENDIF
- IF(SOILTYP.EQ.14.AND.XICE(I,J).EQ.0.)THEN
-#if 0
- IF(IPRINT)PRINT*,' SOIL TYPE FOUND TO BE WATER AT A LAND-POINT'
- IF(IPRINT)PRINT*,i,j,'RESET SOIL in surfce.F'
-#endif
- SOILTYP=7
- ENDIF
- SNOALB1 = SNOALB(I,J)
-! converts canwat in mm to CMC in meters
- CMC=CANWAT(I,J)/1000.
-
-!-------------------------------------------
-!*** convert snow depth from mm to meter
-!
-! IF(RDMAXALB) THEN
-! SNOALB=ALBMAX(I,J)*0.01
-! ELSE
-! SNOALB=MAXALB(IVGTPK)*0.01
-! ENDIF
-
-! SNOALB1=0.80
-! SHMIN=0.00
- ALBBRD=ALBBCK(I,J)
- Z0BRD=Z0(I,J)
- EMBRD=EMBCK(I,J)
- SNOTIME1 = SNOTIME(I,J)
- RIBB=RIB(I,J)
-!FEI: temporaray arrays above need to be changed later by using SI
-
- DO NS=1,NSOIL
- SMC(NS)=SMOIS(I,NS,J)
- STC(NS)=TSLB(I,NS,J) !STEMP
- SWC(NS)=SH2O(I,NS,J)
- ENDDO
-!
- if ( (SNEQV.ne.0..AND.SNOWHK.eq.0.).or.(SNOWHK.le.SNEQV) )THEN
- SNOWHK= 5.*SNEQV
- endif
-!
-
-!Fei: urban. for urban surface, if calling UCM, redefine the natural surface in cities as
-! the "NATURAL" category in the VEGPARM.TBL
- IF(SF_URBAN_PHYSICS == 1.OR. SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN
- IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. &
- IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. &
- IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. &
- IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN
-
- VEGTYP = NATURAL
- SHDFAC = SHDTBL(NATURAL)
- ALBEDOK =0.2 ! 0.2
- ALBBRD =0.2 !0.2
- EMISSI = 0.98 !for VEGTYP=5
- IF ( FRC_URB2D(I,J) < 0.99 ) THEN
- if(sf_urban_physics.eq.1)then
- T1= ( TSK(I,J) -FRC_URB2D(I,J) * TS_URB2D (I,J) )/ (1-FRC_URB2D(I,J))
- elseif((sf_urban_physics.eq.2).OR.(sf_urban_physics.eq.3))then
- T1=tsk_rural_bep(i,j)
- endif
- ELSE
- T1 = TSK(I,J)
- ENDIF
- ENDIF
- ELSE
- IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. &
- IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. &
- IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. &
- IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN
- VEGTYP = ISURBAN
- ENDIF
-
- ENDIF
-
-!===Yang, 2014/10/08, hydrological processes for urban vegetation in single layer UCM===
- AOASIS = 1.0
- USOIL = 1
- DSOIL = 2
- IRIOPTION=IRI_SCHEME
- IF(SF_URBAN_PHYSICS == 1) THEN
- OMG= OMG_URB2D(I,J)
- tloc=mod(int(OMG/3.14159*180./15.+12.+0.5 ),24)
- if (tloc.lt.0) tloc=tloc+24
- if (tloc==0) tloc=24
- CALL cal_mon_day(julian,julyr,jmonth,jday)
- IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. &
- IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. &
- IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. &
- IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN
- AOASIS = oasis ! urban oasis effect
- IF (IRIOPTION ==1) THEN
- IF (tloc==21 .or. tloc==22) THEN !irrigation on vegetaion in urban area, MAY-SEP, 9-10pm
- IF (jmonth==5 .or. jmonth==6 .or. jmonth==7 .or. jmonth==8 .or. jmonth==9) THEN
-! IF (SMC(USOIL) .LT. SMCREF) SMC(USOIL)= SMCREF
-! IF (SMC(DSOIL) .LT. SMCREF) SMC(DSOIL)= SMCREF
- IF (SMC(USOIL) .LT. SMCREF) SMC(USOIL)= REFSMC(ISLTYP(I,J))
- IF (SMC(DSOIL) .LT. SMCREF) SMC(DSOIL)= REFSMC(ISLTYP(I,J))
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- ENDIF
-
- IF(SF_URBAN_PHYSICS == 2 .or. SF_URBAN_PHYSICS == 3) THEN
- IF(AOASIS > 1.0) THEN
- FATAL_ERROR('Urban oasis option is for SF_URBAN_PHYSICS == 1 only')
- ENDIF
- IF(IRIOPTION == 1) THEN
- FATAL_ERROR('Urban irrigation option is for SF_URBAN_PHYSICS == 1 only')
- ENDIF
- ENDIF
-
-#if 0
- IF(IPRINT) THEN
-!
- print*, 'BEFORE SFLX, in Noahlsm_driver'
- print*, 'ICE', ICE, 'DT',DT, 'ZLVL',ZLVL, 'NSOIL', NSOIL, &
- 'SLDPTH', SLDPTH, 'LOCAL',LOCAL, 'LUTYPE',&
- LUTYPE, 'SLTYPE',SLTYPE, 'LWDN',LWDN, 'SOLDN',SOLDN, &
- 'SFCPRS',SFCPRS, 'PRCP',PRCP,'SFCTMP',SFCTMP,'Q2K',Q2K, &
- 'TH2',TH2,'Q2SAT',Q2SAT,'DQSDT2',DQSDT2,'VEGTYP', VEGTYP,&
- 'SOILTYP',SOILTYP, 'SLOPETYP',SLOPETYP, 'SHDFAC',SHDFAC,&
- 'SHMIN',SHMIN, 'ALBBRD',ALBBRD,'SNOALB1',SNOALB1,'TBOT',&
- TBOT, 'Z0BRD',Z0BRD, 'Z0K',Z0K, 'CMC',CMC, 'T1',T1,'STC',&
- STC, 'SMC',SMC, 'SWC',SWC,'SNOWHK',SNOWHK,'SNEQV',SNEQV,&
- 'ALBEDOK',ALBEDOK,'CHK',CHK,'ETA',ETA,'SHEAT',SHEAT, &
- 'ETA_KINEMATIC',ETA_KINEMATIC, 'FDOWN',FDOWN,'EC',EC, &
- 'EDIR',EDIR,'ET',ET,'ETT',ETT,'ESNOW',ESNOW,'DRIP',DRIP,&
- 'DEW',DEW,'BETA',BETA,'ETP',ETP,'SSOIL',SSOIL,'FLX1',FLX1,&
- 'FLX2',FLX2,'FLX3',FLX3,'SNOMLT',SNOMLT,'SNCOVR',SNCOVR,&
- 'RUNOFF1',RUNOFF1,'RUNOFF2',RUNOFF2,'RUNOFF3',RUNOFF3, &
- 'RC',RC, 'PC',PC,'RSMIN',RSMIN,'XLAI',XLAI,'RCS',RCS, &
- 'RCT',RCT,'RCQ',RCQ,'RCSOIL',RCSOIL,'SOILW',SOILW, &
- 'SOILM',SOILM,'Q1',Q1,'SMCWLT',SMCWLT,'SMCDRY',SMCDRY,&
- 'SMCREF',SMCREF,'SMCMAX',SMCMAX,'NROOT',NROOT
- endif
-#endif
-
- IF (rdlai2d) THEN
- IF (SHDFAC > 0.0 .AND. LAI(I,J) <= 0.0) LAI(I,J) = 0.01
- xlai = lai(i,j)
- endif
-
- IF ( ICE == 1 ) THEN
-
- ! Sea-ice case
-
- DO NS = 1, NSOIL
- SH2O(I,NS,J) = 1.0
- ENDDO
- LAI(I,J) = 0.01
-
- CYCLE ILOOP
-
- ELSEIF (ICE == 0) THEN
-
- ! Non-glacial land
-!
-! FASDAS
-!
- IF( fasdas == 1 ) THEN
-
- DZQ = DZ8W(I,1,J)
- XSDA_HFX= SDA_HFX(I,J)*RHO(I,1,J)*CPM(I,J)*DZQ ! W/m^2
- ! TWG2015 Bugfix remove factor of 1000.0 for correct units
- XSDA_QFX= SDA_QFX(I,J)*RHO(I,1,J)*DZQ ! Kg/m2/s of water
- XQNORM = QNORM(I,J)
-
- ENDIF
-!
-! END FASDAS
-!
- CALL SFLX (I,J,FFROZP, ISURBAN, DT,ZLVL,NSOIL,SLDPTH, & !C
- LOCAL, & !L
- LUTYPE, SLTYPE, & !CL
- LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K,DUMMY, & !F
- DUMMY,DUMMY, DUMMY, & !F PRCPRAIN not used
- TH2,Q2SAT,DQSDT2, & !I
- VEGTYP,SOILTYP,SLOPETYP,SHDFAC,SHMIN,SHMAX, & !I
- ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, & !S
- CMC,T1,STC,SMC,SWC,SNOWHK,SNEQV,ALBEDOK,CHK,dummy,& !H
- ETA,SHEAT, ETA_KINEMATIC,FDOWN, & !O
- EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, & !O
- BETA,ETP,SSOIL, & !O
- FLX1,FLX2,FLX3, & !O
- FLX4,FVB,FBUR,FGSN,UA_PHYS, & !UA
- SNOMLT,SNCOVR, & !O
- RUNOFF1,RUNOFF2,RUNOFF3, & !O
- RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, & !O
- SOILW,SOILM,Q1,SMAV, & !D
- RDLAI2D,USEMONALB, &
- SNOTIME1, &
- RIBB, &
- SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT, &
- sfcheadrt(i,j), & !I
- INFXSRT(i,j),ETPND1,OPT_THCND,AOASIS & !O
- ,XSDA_QFX, HFX_PHY, QFX_PHY, XQNORM, fasdas, HCPCT_FASDAS & ! fasdas
- ,IRRIGATION_CHANNEL)
-
-
-#ifdef WRF_HYDRO
- soldrain(i,j) = RUNOFF2*DT*1000.0
-#endif
- ELSEIF (ICE == -1) THEN
-
- !
- ! Set values that the LSM is expected to update,
- ! but don't get updated for glacial points.
- !
- SOILM = 0.0 !BSINGH(PNNL)- SOILM is undefined for this case, it is used for diagnostics so setting it to zero
- XLAI = 0.01 ! KWM Should this be Zero over land ice? Does this value matter?
- RUNOFF2 = 0.0
- RUNOFF3 = 0.0
- DO NS = 1, NSOIL
- SWC(NS) = 1.0
- SMC(NS) = 1.0
- SMAV(NS) = 1.0
- ENDDO
-!
-! FASDAS
-!
- IF( fasdas == 1 ) THEN
-
- DZQ = DZ8W(I,1,J)
- XSDA_HFX= SDA_HFX(I,J)*RHO(I,1,J)*CPM(I,J)*DZQ ! W/m^2
- XSDA_QFX= 0.0 ! Kg/m2/s of water
- XQNORM = 0.0
-
- ENDIF
-!
-! END FASDAS
-!
-
- CALL SFLX_GLACIAL(I,J,ISICE,FFROZP,DT,ZLVL,NSOIL,SLDPTH, & !C
- & LWDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K, & !F
- & TH2,Q2SAT,DQSDT2, & !I
- & ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, & !S
- & T1,STC(1:NSOIL),SNOWHK,SNEQV,ALBEDOK,CHK, & !H
- & ETA,SHEAT,ETA_KINEMATIC,FDOWN, & !O
- & ESNOW,DEW, & !O
- & ETP,SSOIL, & !O
- & FLX1,FLX2,FLX3, & !O
- & SNOMLT,SNCOVR, & !O
- & RUNOFF1, & !O
- & Q1, & !D
- & SNOTIME1, &
- & RIBB)
-
- ENDIF
-
- lai(i,j) = xlai
- if (present(rc2) .and. present(xlai2)) then
- rc2(I,J) = RC ! for output
- xlai2(I,J) = XLAI
- endif
-
-#if 0
- IF(IPRINT) THEN
-
- print*, 'AFTER SFLX, in Noahlsm_driver'
- print*, 'ICE', ICE, 'DT',DT, 'ZLVL',ZLVL, 'NSOIL', NSOIL, &
- 'SLDPTH', SLDPTH, 'LOCAL',LOCAL, 'LUTYPE',&
- LUTYPE, 'SLTYPE',SLTYPE, 'LWDN',LWDN, 'SOLDN',SOLDN, &
- 'SFCPRS',SFCPRS, 'PRCP',PRCP,'SFCTMP',SFCTMP,'Q2K',Q2K, &
- 'TH2',TH2,'Q2SAT',Q2SAT,'DQSDT2',DQSDT2,'VEGTYP', VEGTYP,&
- 'SOILTYP',SOILTYP, 'SLOPETYP',SLOPETYP, 'SHDFAC',SHDFAC,&
- 'SHDMIN',SHMIN, 'ALBBRD',ALBBRD,'SNOALB',SNOALB1,'TBOT',&
- TBOT, 'Z0BRD',Z0BRD, 'Z0K',Z0K, 'CMC',CMC, 'T1',T1,'STC',&
- STC, 'SMC',SMC, 'SWc',SWC,'SNOWHK',SNOWHK,'SNEQV',SNEQV,&
- 'ALBEDOK',ALBEDOK,'CHK',CHK,'ETA',ETA,'SHEAT',SHEAT, &
- 'ETA_KINEMATIC',ETA_KINEMATIC, 'FDOWN',FDOWN,'EC',EC, &
- 'EDIR',EDIR,'ET',ET,'ETT',ETT,'ESNOW',ESNOW,'DRIP',DRIP,&
- 'DEW',DEW,'BETA',BETA,'ETP',ETP,'SSOIL',SSOIL,'FLX1',FLX1,&
- 'FLX2',FLX2,'FLX3',FLX3,'SNOMLT',SNOMLT,'SNCOVR',SNCOVR,&
- 'RUNOFF1',RUNOFF1,'RUNOFF2',RUNOFF2,'RUNOFF3',RUNOFF3, &
- 'RC',RC, 'PC',PC,'RSMIN',RSMIN,'XLAI',XLAI,'RCS',RCS, &
- 'RCT',RCT,'RCQ',RCQ,'RCSOIL',RCSOIL,'SOILW',SOILW, &
- 'SOILM',SOILM,'Q1',Q1,'SMCWLT',SMCWLT,'SMCDRY',SMCDRY,&
- 'SMCREF',SMCREF,'SMCMAX',SMCMAX,'NROOT',NROOT
- endif
-#endif
-
-!*** UPDATE STATE VARIABLES
- CANWAT(I,J)=CMC*1000.
- SNOW(I,J)=SNEQV*1000.
-! SNOWH(I,J)=SNOWHK*1000.
- SNOWH(I,J)=SNOWHK ! SNOWHK in meters
- ALBEDO(I,J)=ALBEDOK
- ALB_RURAL(I,J)=ALBEDOK
- ALBBCK(I,J)=ALBBRD
- Z0(I,J)=Z0BRD
- EMISS(I,J) = EMISSI
- EMISS_RURAL(I,J) = EMISSI
-! Noah: activate time-varying roughness length (V3.3 Feb 2011)
- ZNT(I,J)=Z0K
-!
-! FASDAS
-!
-! Update Skin Temperature
- IF( fasdas == 1 ) THEN
- XSDA_QFX= XSDA_QFX*ELWV*XQNORM
-
- !TWG2015 Bugfix to multiply Heat Capacity by Soil Depth for correct
- !units
-
- T1 = T1 + (XSDA_HFX-XSDA_QFX)*DT/(HCPCT_FASDAS*DZS(1))
-
- END IF
-!
-! END FASDAS
-!
- TSK(I,J)=T1
- TSK_RURAL(I,J)=T1
- if (present(tsk_rural_bep)) then
- IF(SF_URBAN_PHYSICS == 2 .or. SF_URBAN_PHYSICS == 3) THEN
- TSK_RURAL_BEP(I,J)=T1
- END IF
- endif
- HFX(I,J)=SHEAT
- HFX_RURAL(I,J)=SHEAT
-! MEk Jul07 add potential evap accum
- POTEVP(I,J)=POTEVP(I,J)+ETP*FDTW
- QFX(I,J)=ETA_KINEMATIC
- QFX_RURAL(I,J)=ETA_KINEMATIC
-
-#ifdef WRF_HYDRO
-!added by Wei Yu
-! QFX(I,J) = QFX(I,J) + ETPND1
-! ETA = ETA + ETPND1/2.501E6*dt
-!end added by Wei Yu
-#endif
-
-
- LH(I,J)=ETA
- LH_RURAL(I,J)=ETA
- GRDFLX(I,J)=SSOIL
- GRDFLX_RURAL(I,J)=SSOIL
- SNOWC(I,J)=SNCOVR
- CHS2(I,J)=CQS2(I,J)
- SNOTIME(I,J) = SNOTIME1
-! prevent diagnostic ground q (q1) from being greater than qsat(tsk)
-! as happens over snow cover where the cqs2 value also becomes irrelevant
-! by setting cqs2=chs in this situation the 2m q should become just qv(k=1)
-! ww: comment out this change to avoid Q2 drop due to change of radiative flux
-! IF (Q1 .GT. QSFC(I,J)) THEN
-! CQS2(I,J) = CHS(I,J)
-! ENDIF
-! QSFC(I,J)=Q1
-! Convert QSFC back to mixing ratio
- QSFC(I,J)= Q1/(1.0-Q1)
-!
- ! QSFC_RURAL(I,J)= Q1/(1.0-Q1)
-! Calculate momentum flux from rural surface for use with multi-layer UCM (Martilli et al. 2002)
-
- DO 80 NS=1,NSOIL
- SMOIS(I,NS,J)=SMC(NS)
- TSLB(I,NS,J)=STC(NS) ! STEMP
- SH2O(I,NS,J)=SWC(NS)
- 80 CONTINUE
-! ENDIF
-
- FLX4_2D(I,J) = FLX4
- FVB_2D(I,J) = FVB
- FBUR_2D(I,J) = FBUR
- FGSN_2D(I,J) = FGSN
-
- !
- ! Residual of surface energy balance equation terms
- !
-
- IF ( UA_PHYS ) THEN
- noahres(i,j) = ( solnet + lwdn ) - sheat + ssoil - eta &
- - ( emissi * STBOLT * (t1**4) ) - flx1 - flx2 - flx3 - flx4
-
- ELSE
- noahres(i,j) = ( solnet + lwdn ) - sheat + ssoil - eta &
- - ( emissi * STBOLT * (t1**4) ) - flx1 - flx2 - flx3
- ENDIF
-
-
- IF (SF_URBAN_PHYSICS == 1 ) THEN ! Beginning of UCM CALL if block
-!--------------------------------------
-! URBAN CANOPY MODEL START - urban
-!--------------------------------------
-! Input variables lsm --> urban
-
- IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. &
- IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. &
- IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. &
- IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN
-
-
-! Call urban
-
-!
- UTYPE_URB = UTYPE_URB2D(I,J) !urban type (low, high or industrial)
-
- TA_URB = SFCTMP ! [K]
- QA_URB = Q2K ! [kg/kg]
- UA_URB = SQRT(U_PHY(I,1,J)**2.+V_PHY(I,1,J)**2.)
- U1_URB = U_PHY(I,1,J)
- V1_URB = V_PHY(I,1,J)
- IF(UA_URB < 1.) UA_URB=1. ! [m/s]
- SSG_URB = SOLDN ! [W/m/m]
- SSGD_URB = 0.8*SOLDN ! [W/m/m]
- SSGQ_URB = SSG_URB-SSGD_URB ! [W/m/m]
- LLG_URB = GLW(I,J) ! [W/m/m]
- RAIN_URB = RAINBL(I,J) ! [mm]
- RHOO_URB = SFCPRS / (287.04 * SFCTMP * (1.0+ 0.61 * Q2K)) ![kg/m/m/m]
- ZA_URB = ZLVL ! [m]
- DELT_URB = DT ! [sec]
- XLAT_URB = XLAT_URB2D(I,J) ! [deg]
- COSZ_URB = COSZ_URB2D(I,J) !
- OMG_URB = OMG_URB2D(I,J) !
- ZNT_URB = ZNT(I,J)
-
- LSOLAR_URB = .FALSE.
-
- TR_URB = TR_URB2D(I,J)
- TB_URB = TB_URB2D(I,J)
- TG_URB = TG_URB2D(I,J)
- TC_URB = TC_URB2D(I,J)
- QC_URB = QC_URB2D(I,J)
- UC_URB = UC_URB2D(I,J)
-
- TGR_URB = TGR_URB2D(I,J)
- CMCR_URB = CMCR_URB2D(I,J)
- FLXHUMR_URB = FLXHUMR_URB2D(I,J)
- FLXHUMB_URB = FLXHUMB_URB2D(I,J)
- FLXHUMG_URB = FLXHUMG_URB2D(I,J)
- DRELR_URB = DRELR_URB2D(I,J)
- DRELB_URB = DRELB_URB2D(I,J)
- DRELG_URB = DRELG_URB2D(I,J)
-
- DO K = 1,num_roof_layers
- TRL_URB(K) = TRL_URB3D(I,K,J)
- SMR_URB(K) = SMR_URB3D(I,K,J)
- TGRL_URB(K)= TGRL_URB3D(I,K,J)
- END DO
- DO K = 1,num_wall_layers
- TBL_URB(K) = TBL_URB3D(I,K,J)
- END DO
- DO K = 1,num_road_layers
- TGL_URB(K) = TGL_URB3D(I,K,J)
- END DO
-
- XXXR_URB = XXXR_URB2D(I,J)
- XXXB_URB = XXXB_URB2D(I,J)
- XXXG_URB = XXXG_URB2D(I,J)
- XXXC_URB = XXXC_URB2D(I,J)
-!
-!
-! Limits to avoid dividing by small number
- if (CHS(I,J) < 1.0E-02) then
- CHS(I,J) = 1.0E-02
- endif
- if (CHS2(I,J) < 1.0E-02) then
- CHS2(I,J) = 1.0E-02
- endif
- if (CQS2(I,J) < 1.0E-02) then
- CQS2(I,J) = 1.0E-02
- endif
-!
- CHS_URB = CHS(I,J)
- CHS2_URB = CHS2(I,J)
- IF (PRESENT(CMR_SFCDIF)) THEN
- CMR_URB = CMR_SFCDIF(I,J)
- CHR_URB = CHR_SFCDIF(I,J)
- CMGR_URB = CMGR_SFCDIF(I,J)
- CHGR_URB = CHGR_SFCDIF(I,J)
- CMC_URB = CMC_SFCDIF(I,J)
- CHC_URB = CHC_SFCDIF(I,J)
- ENDIF
-
-! NUDAPT for SLUCM
- mh_urb = mh_urb2d(I,J)
- stdh_urb = stdh_urb2d(I,J)
- lp_urb = lp_urb2d(I,J)
- hgt_urb = hgt_urb2d(I,J)
- lf_urb = 0.0
- DO K = 1,4
- lf_urb(K)=lf_urb2d(I,K,J)
- ENDDO
- frc_urb = frc_urb2d(I,J)
- lb_urb = lb_urb2d(I,J)
- check = 0
- if (I.eq.73.and.J.eq.125)THEN
- check = 1
- end if
-!
-! Call urban
- CALL cal_mon_day(julian,julyr,jmonth,jday)
- CALL urban(LSOLAR_URB, & ! I
- num_roof_layers,num_wall_layers,num_road_layers, & ! C
- DZR,DZB,DZG, & ! C
- UTYPE_URB,TA_URB,QA_URB,UA_URB,U1_URB,V1_URB,SSG_URB, & ! I
- SSGD_URB,SSGQ_URB,LLG_URB,RAIN_URB,RHOO_URB, & ! I
- ZA_URB,DECLIN_URB,COSZ_URB,OMG_URB, & ! I
- XLAT_URB,DELT_URB,ZNT_URB, & ! I
- CHS_URB, CHS2_URB, & ! I
- TR_URB, TB_URB, TG_URB, TC_URB, QC_URB,UC_URB, & ! H
- TRL_URB,TBL_URB,TGL_URB, & ! H
- XXXR_URB, XXXB_URB, XXXG_URB, XXXC_URB, & ! H
- TS_URB,QS_URB,SH_URB,LH_URB,LH_KINEMATIC_URB, & ! O
- SW_URB,ALB_URB,LW_URB,G_URB,RN_URB,PSIM_URB,PSIH_URB, & ! O
- GZ1OZ0_URB, & !O
- CMR_URB, CHR_URB, CMC_URB, CHC_URB, &
- U10_URB, V10_URB, TH2_URB, Q2_URB, & ! O
- UST_URB,mh_urb, stdh_urb, lf_urb, lp_urb, & ! 0
- hgt_urb,frc_urb,lb_urb, check,CMCR_URB,TGR_URB, & ! H
- TGRL_URB,SMR_URB,CMGR_URB,CHGR_URB,jmonth, & ! H
- DRELR_URB,DRELB_URB, & ! H
- DRELG_URB,FLXHUMR_URB,FLXHUMB_URB,FLXHUMG_URB)
-
-#if 0
- IF(IPRINT) THEN
-
- print*, 'AFTER CALL URBAN'
- print*,'num_roof_layers',num_roof_layers, 'num_wall_layers', &
- num_wall_layers, &
- 'DZR',DZR,'DZB',DZB,'DZG',DZG,'UTYPE_URB',UTYPE_URB,'TA_URB', &
- TA_URB, &
- 'QA_URB',QA_URB,'UA_URB',UA_URB,'U1_URB',U1_URB,'V1_URB', &
- V1_URB, &
- 'SSG_URB',SSG_URB,'SSGD_URB',SSGD_URB,'SSGQ_URB',SSGQ_URB, &
- 'LLG_URB',LLG_URB,'RAIN_URB',RAIN_URB,'RHOO_URB',RHOO_URB, &
- 'ZA_URB',ZA_URB, 'DECLIN_URB',DECLIN_URB,'COSZ_URB',COSZ_URB,&
- 'OMG_URB',OMG_URB,'XLAT_URB',XLAT_URB,'DELT_URB',DELT_URB, &
- 'ZNT_URB',ZNT_URB,'TR_URB',TR_URB, 'TB_URB',TB_URB,'TG_URB',&
- TG_URB,'TC_URB',TC_URB,'QC_URB',QC_URB,'TRL_URB',TRL_URB, &
- 'TBL_URB',TBL_URB,'TGL_URB',TGL_URB,'XXXR_URB',XXXR_URB, &
- 'XXXB_URB',XXXB_URB,'XXXG_URB',XXXG_URB,'XXXC_URB',XXXC_URB,&
- 'TS_URB',TS_URB,'QS_URB',QS_URB,'SH_URB',SH_URB,'LH_URB', &
- LH_URB, 'LH_KINEMATIC_URB',LH_KINEMATIC_URB,'SW_URB',SW_URB,&
- 'ALB_URB',ALB_URB,'LW_URB',LW_URB,'G_URB',G_URB,'RN_URB', &
- RN_URB, 'PSIM_URB',PSIM_URB,'PSIH_URB',PSIH_URB, &
- 'U10_URB',U10_URB,'V10_URB',V10_URB,'TH2_URB',TH2_URB, &
- 'Q2_URB',Q2_URB,'CHS_URB',CHS_URB,'CHS2_URB',CHS2_URB
- endif
-#endif
-
- TS_URB2D(I,J) = TS_URB
-
- ALBEDO(I,J) = FRC_URB2D(I,J)*ALB_URB+(1-FRC_URB2D(I,J))*ALBEDOK ![-]
- HFX(I,J) = FRC_URB2D(I,J)*SH_URB+(1-FRC_URB2D(I,J))*SHEAT ![W/m/m]
- QFX(I,J) = FRC_URB2D(I,J)*LH_KINEMATIC_URB &
- + (1-FRC_URB2D(I,J))*ETA_KINEMATIC ![kg/m/m/s]
- LH(I,J) = FRC_URB2D(I,J)*LH_URB+(1-FRC_URB2D(I,J))*ETA ![W/m/m]
- GRDFLX(I,J) = FRC_URB2D(I,J)*G_URB+(1-FRC_URB2D(I,J))*SSOIL ![W/m/m]
- TSK(I,J) = FRC_URB2D(I,J)*TS_URB+(1-FRC_URB2D(I,J))*T1 ![K]
- Q1 = FRC_URB2D(I,J)*QS_URB+(1-FRC_URB2D(I,J))*Q1 ![-]
-! Convert QSFC back to mixing ratio
- QSFC(I,J)= Q1/(1.0-Q1)
- UST(I,J)= FRC_URB2D(I,J)*UST_URB+(1-FRC_URB2D(I,J))*UST(I,J) ![m/s]
-
-#if 0
- IF(IPRINT)THEN
-
- print*, ' FRC_URB2D', FRC_URB2D, &
- 'ALB_URB',ALB_URB, 'ALBEDOK',ALBEDOK, &
- 'ALBEDO(I,J)', ALBEDO(I,J), &
- 'SH_URB',SH_URB,'SHEAT',SHEAT, 'HFX(I,J)',HFX(I,J), &
- 'LH_KINEMATIC_URB',LH_KINEMATIC_URB,'ETA_KINEMATIC', &
- ETA_KINEMATIC, 'QFX(I,J)',QFX(I,J), &
- 'LH_URB',LH_URB, 'ETA',ETA, 'LH(I,J)',LH(I,J), &
- 'G_URB',G_URB,'SSOIL',SSOIL,'GRDFLX(I,J)', GRDFLX(I,J),&
- 'TS_URB',TS_URB,'T1',T1,'TSK(I,J)',TSK(I,J), &
- 'QS_URB',QS_URB,'Q1',Q1,'QSFC(I,J)',QSFC(I,J)
- endif
-#endif
-
-
-
-! Renew Urban State Varialbes
-
- TR_URB2D(I,J) = TR_URB
- TB_URB2D(I,J) = TB_URB
- TG_URB2D(I,J) = TG_URB
- TC_URB2D(I,J) = TC_URB
- QC_URB2D(I,J) = QC_URB
- UC_URB2D(I,J) = UC_URB
-
- TGR_URB2D(I,J) =TGR_URB
- CMCR_URB2D(I,J)=CMCR_URB
- FLXHUMR_URB2D(I,J)=FLXHUMR_URB
- FLXHUMB_URB2D(I,J)=FLXHUMB_URB
- FLXHUMG_URB2D(I,J)=FLXHUMG_URB
- DRELR_URB2D(I,J) = DRELR_URB
- DRELB_URB2D(I,J) = DRELB_URB
- DRELG_URB2D(I,J) = DRELG_URB
-
- DO K = 1,num_roof_layers
- TRL_URB3D(I,K,J) = TRL_URB(K)
- SMR_URB3D(I,K,J) = SMR_URB(K)
- TGRL_URB3D(I,K,J)= TGRL_URB(K)
- END DO
- DO K = 1,num_wall_layers
- TBL_URB3D(I,K,J) = TBL_URB(K)
- END DO
- DO K = 1,num_road_layers
- TGL_URB3D(I,K,J) = TGL_URB(K)
- END DO
- XXXR_URB2D(I,J) = XXXR_URB
- XXXB_URB2D(I,J) = XXXB_URB
- XXXG_URB2D(I,J) = XXXG_URB
- XXXC_URB2D(I,J) = XXXC_URB
-
- SH_URB2D(I,J) = SH_URB
- LH_URB2D(I,J) = LH_URB
- G_URB2D(I,J) = G_URB
- RN_URB2D(I,J) = RN_URB
- PSIM_URB2D(I,J) = PSIM_URB
- PSIH_URB2D(I,J) = PSIH_URB
- GZ1OZ0_URB2D(I,J)= GZ1OZ0_URB
- U10_URB2D(I,J) = U10_URB
- V10_URB2D(I,J) = V10_URB
- TH2_URB2D(I,J) = TH2_URB
- Q2_URB2D(I,J) = Q2_URB
- UST_URB2D(I,J) = UST_URB
- AKMS_URB2D(I,J) = KARMAN * UST_URB2D(I,J)/(GZ1OZ0_URB2D(I,J)-PSIM_URB2D(I,J))
- IF (PRESENT(CMR_SFCDIF)) THEN
- CMR_SFCDIF(I,J) = CMR_URB
- CHR_SFCDIF(I,J) = CHR_URB
- CMGR_SFCDIF(I,J) = CMGR_URB
- CHGR_SFCDIF(I,J) = CHGR_URB
- CMC_SFCDIF(I,J) = CMC_URB
- CHC_SFCDIF(I,J) = CHC_URB
- ENDIF
- END IF
-
- ENDIF ! end of UCM CALL if block
-!--------------------------------------
-! Urban Part End - urban
-!--------------------------------------
-
-!*** DIAGNOSTICS
- SMSTAV(I,J)=SOILW
- SMSTOT(I,J)=SOILM*1000.
- DO NS=1,NSOIL
- SMCREL(I,NS,J)=SMAV(NS)
- ENDDO
-
-
-! Convert the water unit into mm
- SFCRUNOFF(I,J)=SFCRUNOFF(I,J)+RUNOFF1*DT*1000.0
- UDRUNOFF(I,J)=UDRUNOFF(I,J)+RUNOFF2*DT*1000.0
-! snow defined when fraction of frozen precip (FFROZP) > 0.5,
- IF(FFROZP.GT.0.5)THEN
- ACSNOW(I,J)=ACSNOW(I,J)+PRCP*DT
- ENDIF
- IF(SNOW(I,J).GT.0.)THEN
- ACSNOM(I,J)=ACSNOM(I,J)+SNOMLT*1000.
-! accumulated snow-melt energy
- SNOPCX(I,J)=SNOPCX(I,J)-SNOMLT/FDTLIW
- ENDIF
-
- ENDIF ! endif of land-sea test
-
- ENDDO ILOOP ! of I loop
- ENDDO JLOOP ! of J loop
-
- IF (SF_URBAN_PHYSICS == 2) THEN
-
-
- do j=jts,jte
- do i=its,ite
- EMISS_URB(i,j)=0.
- RL_UP_URB(i,j)=0.
- RS_ABS_URB(i,j)=0.
- GRDFLX_URB(i,j)=0.
- b_q_bep(i,kts:kte,j)=0.
- end do
- end do
- CALL BEP(frc_urb2d,utype_urb2d,itimestep,dz8w,dt,u_phy,v_phy, &
- th_phy,rho,p_phy,swdown,glw, &
- gmt,julday,xlong,xlat,declin_urb,cosz_urb2d,omg_urb2d, &
- num_urban_ndm, urban_map_zrd, urban_map_zwd, urban_map_gd, &
- urban_map_zd, urban_map_zdf, urban_map_bd, urban_map_wd, &
- urban_map_gbd, urban_map_fbd, num_urban_hi, &
- trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, &
- sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d, &
- lp_urb2d,hi_urb2d,lb_urb2d,hgt_urb2d, &
- a_u_bep,a_v_bep,a_t_bep, &
- a_e_bep,b_u_bep,b_v_bep, &
- b_t_bep,b_e_bep,b_q_bep,dlg_bep, &
- dl_u_bep,sf_bep,vl_bep, &
- rl_up_urb,rs_abs_urb,emiss_urb,grdflx_urb, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte )
-
- ENDIF
-
-
- IF (SF_URBAN_PHYSICS == 3) THEN
-
-
- do j=jts,jte
- do i=its,ite
- EMISS_URB(i,j)=0.
- RL_UP_URB(i,j)=0.
- RS_ABS_URB(i,j)=0.
- GRDFLX_URB(i,j)=0.
- b_q_bep(i,kts:kte,j)=0.
- end do
- end do
-
-
- CALL BEP_BEM(frc_urb2d,utype_urb2d,itimestep,dz8w,dt,u_phy,v_phy, &
- th_phy,rho,p_phy,swdown,glw, &
- gmt,julday,xlong,xlat,declin_urb,cosz_urb2d,omg_urb2d, &
- num_urban_ndm, urban_map_zrd, urban_map_zwd, urban_map_gd, &
- urban_map_zd, urban_map_zdf, urban_map_bd, urban_map_wd, &
- urban_map_gbd, urban_map_fbd, urban_map_zgrd, num_urban_hi, &
- trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, &
- tlev_urb3d,qlev_urb3d,tw1lev_urb3d,tw2lev_urb3d, &
- tglev_urb3d,tflev_urb3d,sf_ac_urb3d,lf_ac_urb3d, &
- cm_ac_urb3d,sfvent_urb3d,lfvent_urb3d, &
- sfwin1_urb3d,sfwin2_urb3d, &
- sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d, &
- ep_pv_urb3d,t_pv_urb3d, & !RMS
- trv_urb4d,qr_urb4d,qgr_urb3d,tgr_urb3d, & !RMS
- drain_urb4d,draingr_urb3d,sfrv_urb3d, & !RMS
- lfrv_urb3d,dgr_urb3d,dg_urb3d,lfr_urb3d,lfg_urb3d, & !RMS
- rainbl,swddir,swddif, & !RMS
- lp_urb2d,hi_urb2d,lb_urb2d,hgt_urb2d, &
- a_u_bep,a_v_bep,a_t_bep, &
- a_e_bep,b_u_bep,b_v_bep, &
- b_t_bep,b_e_bep,b_q_bep,dlg_bep, &
- dl_u_bep,sf_bep,vl_bep, &
- rl_up_urb,rs_abs_urb,emiss_urb,grdflx_urb,qv3d, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte )
-
- ENDIF
-
- if((sf_urban_physics.eq.2).OR.(sf_urban_physics.eq.3))then !Bep begin
- do j=jts,jte
- do i=its,ite
- UMOM_URB(I,J)=0.
- VMOM_URB(I,J)=0.
- HFX_URB(I,J)=0.
- QFX_URB(I,J)=0.
- do k=kts,kte
- a_u_bep(i,k,j)=a_u_bep(i,k,j)*frc_urb2d(i,j)
- a_v_bep(i,k,j)=a_v_bep(i,k,j)*frc_urb2d(i,j)
- a_t_bep(i,k,j)=a_t_bep(i,k,j)*frc_urb2d(i,j)
- a_q_bep(i,k,j)=0.
- a_e_bep(i,k,j)=0.
- b_u_bep(i,k,j)=b_u_bep(i,k,j)*frc_urb2d(i,j)
- b_v_bep(i,k,j)=b_v_bep(i,k,j)*frc_urb2d(i,j)
- b_t_bep(i,k,j)=b_t_bep(i,k,j)*frc_urb2d(i,j)
- b_q_bep(i,k,j)=b_q_bep(i,k,j)*frc_urb2d(i,j)
- b_e_bep(i,k,j)=b_e_bep(i,k,j)*frc_urb2d(i,j)
- HFX_URB(I,J)=HFX_URB(I,J)+B_T_BEP(I,K,J)*RHO(I,K,J)*CP* &
- DZ8W(I,K,J)*VL_BEP(I,K,J)
- QFX_URB(I,J)=QFX_URB(I,J)+B_Q_BEP(I,K,J)* &
- DZ8W(I,K,J)*VL_BEP(I,K,J)
- UMOM_URB(I,J)=UMOM_URB(I,J)+ (A_U_BEP(I,K,J)*U_PHY(I,K,J)+ &
- B_U_BEP(I,K,J))*DZ8W(I,K,J)*VL_BEP(I,K,J)
- VMOM_URB(I,J)=VMOM_URB(I,J)+ (A_V_BEP(I,K,J)*V_PHY(I,K,J)+ &
- B_V_BEP(I,K,J))*DZ8W(I,K,J)*VL_BEP(I,K,J)
- vl_bep(i,k,j)=(1.-frc_urb2d(i,j))+vl_bep(i,k,j)*frc_urb2d(i,j)
- sf_bep(i,k,j)=(1.-frc_urb2d(i,j))+sf_bep(i,k,j)*frc_urb2d(i,j)
- end do
- a_u_bep(i,1,j)=(1.-frc_urb2d(i,j))*(-ust(I,J)*ust(I,J))/dz8w(i,1,j)/ &
- ((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)+a_u_bep(i,1,j)
- a_v_bep(i,1,j)=(1.-frc_urb2d(i,j))*(-ust(I,J)*ust(I,J))/dz8w(i,1,j)/ &
- ((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)+a_v_bep(i,1,j)
- b_t_bep(i,1,j)=(1.-frc_urb2d(i,j))*hfx_rural(i,j)/dz8w(i,1,j)/rho(i,1,j)/CP+ &
- b_t_bep(i,1,j)
- b_q_bep(i,1,j)=(1.-frc_urb2d(i,j))*qfx_rural(i,j)/dz8w(i,1,j)/rho(i,1,j)+b_q_bep(i,1,j)
- umom=(1.-frc_urb2d(i,j))*ust(i,j)*ust(i,j)*u_phy(i,1,j)/ &
- ((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)+umom_urb(i,j)
- vmom=(1.-frc_urb2d(i,j))*ust(i,j)*ust(i,j)*v_phy(i,1,j)/ &
- ((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)+vmom_urb(i,j)
- sf_bep(i,1,j)=1.
-
-! compute upward longwave radiation from the rural part and total
-! rl_up_rural=-emiss_rural(i,j)*sigma_sb*(tsk_rural(i,j)**4.)-(1.-emiss_rural(i,j))*glw(i,j)
-! rl_up_tot=(1.-frc_urb2d(i,j))*rl_up_rural+frc_urb2d(i,j)*rl_up_urb(i,j)
-! emiss(i,j)=(1.-frc_urb2d(i,j))*emiss_rural(i,j)+frc_urb2d(i,j)*emiss_urb(i,j)
-! using the emissivity and the total longwave upward radiation estimate the averaged skin temperature
- IF (FRC_URB2D(I,J).GT.0.) THEN
- rl_up_rural=-emiss_rural(i,j)*sigma_sb*(tsk_rural(i,j)**4.)-(1.-emissi)*glw(i,j)
- rl_up_tot=(1.-frc_urb2d(i,j))*rl_up_rural+frc_urb2d(i,j)*rl_up_urb(i,j)
- emiss(i,j)=(1.-frc_urb2d(i,j))*emiss_rural(i,j)+frc_urb2d(i,j)*emiss_urb(i,j)
- ts_urb2d(i,j)=(max(0.,(-rl_up_urb(i,j)-(1.-emiss_urb(i,j))*glw(i,j))/emiss_urb(i,j)/sigma_sb))**0.25
- tsk(i,j)=(max(0., (-1.*rl_up_tot-(1.-emiss(i,j))*glw(i,j) )/emiss(i,j)/sigma_sb))**.25
- rs_abs_tot=(1.-frc_urb2d(i,j))*swdown(i,j)*(1.-albedo(i,j))+frc_urb2d(i,j)*rs_abs_urb(i,j)
- if(swdown(i,j).gt.0.)then
- albedo(i,j)=1.-rs_abs_tot/swdown(i,j)
- else
- albedo(i,j)=alb_rural(i,j)
- endif
-! rename *_urb to sh_urb2d,lh_urb2d,g_urb2d,rn_urb2d
- grdflx(i,j)= (1.-frc_urb2d(i,j))*grdflx_rural(i,j)+frc_urb2d(i,j)*grdflx_urb(i,j)
- qfx(i,j)=(1.-frc_urb2d(i,j))*qfx_rural(i,j)+qfx_urb(i,j)
-! lh(i,j)=(1.-frc_urb2d(i,j))*qfx_rural(i,j)*xlv
- lh(i,j)=qfx(i,j)*xlv
- HFX(I,J) = HFX_URB(I,J)+(1-FRC_URB2D(I,J))*HFX_RURAL(I,J) ![W/m/m]
- SH_URB2D(I,J) = HFX_URB(I,J)/FRC_URB2D(I,J)
- LH_URB2D(I,J) = qfx_urb(i,j)*xlv
- G_URB2D(I,J) = grdflx_urb(i,j)
- RN_URB2D(I,J) = rs_abs_urb(i,j)+emiss_urb(i,j)*glw(i,j)-rl_up_urb(i,j)
- ust(i,j)=(umom**2.+vmom**2.)**.25
-! if(tsk(i,j).gt.350)write(*,*)'tsk too big!',i,j,tsk(i,j)
-! if(tsk(i,j).lt.260)write(*,*)'tsk too small!',i,j,tsk(i,j),rl_up_tot,rl_up_urb(i,j),rl_up_rural
-! print*,'ivgtyp,i,j,sigma_sb',ivgtyp(i,j),i,j,sigma_sb
-! print*,'hfx,lh,qfx,grdflx,ts_urb2d',hfx(i,j),lh(i,j),qfx(i,j),grdflx(i,j),ts_urb2d(i,j)
-! print*,'tsk,albedo,emiss',tsk(i,j),albedo(i,j),emiss(i,j)
-! if(i.eq.56.and.j.eq.29)then
-! print*,'ivgtyp, qfx, hfx',ivgtyp(i,j),hfx_rural(i,j),qfx_rural(i,j)
-! print*,'emiss_rural,emiss_urb',emiss_rural(i,j),emiss_urb(i,j)
-! print*,'rl_up_rural,rl_up_urb(i,j)',rl_up_rural,rl_up_urb(i,j)
-! print*,'tsk_rural,ts_urb2d(i,j),tsk',tsk_rural(i,j),ts_urb2d(i,j),tsk(i,j)
-! print*,'reconstruction fei',((emiss(i,j)*tsk(i,j)**4.-frc_urb2d(i,j)*emiss_urb(i,j)*ts_urb2d(i,j)**4.)/(emiss_rural(i,j)*(1.-frc_urb2d(i,j))))**.25
-! print*,'ivgtyp,hfx,hfx_urb,hfx_rural',hfx(i,j),hfx_urb(i,j),hfx_rural(i,j)
-! print*,'lh,lh_rural',lh(i,j),lh_rural(i,j)
-! print*,'qfx',qfx(i,j)
-! print*,'ts_urb2d',ts_urb2d(i,j)
-! print*,'ust',ust(i,j)
-! print*,'swdown,glw',swdown(i,j),glw(i,j)
-! endif
- else
- SH_URB2D(I,J) = 0.
- LH_URB2D(I,J) = 0.
- G_URB2D(I,J) = 0.
- RN_URB2D(I,J) = 0.
- endif
- enddo
- enddo
-
- endif !Bep end
-
-!------------------------------------------------------
- END SUBROUTINE lsm
-!------------------------------------------------------
-
-!For MPAS, the below section of the module is moved to module_physics_lsm_noahinit.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 subroutine.
-
-#if defined(wrfmodel)
- SUBROUTINE LSMINIT(VEGFRA,SNOW,SNOWC,SNOWH,CANWAT,SMSTAV, &
- SMSTOT, SFCRUNOFF,UDRUNOFF,ACSNOW, &
- ACSNOM,IVGTYP,ISLTYP,TSLB,SMOIS,SH2O,ZS,DZS, &
- MMINLU, &
- SNOALB, FNDSOILW, FNDSNOWH, RDMAXALB, &
- num_soil_layers, restart, &
- allowed_to_read , &
- irr_rand_field,irr_ph,irr_freq, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte &
- )
-
- INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte
-
- INTEGER, INTENT(IN) :: num_soil_layers
-
- LOGICAL , INTENT(IN) :: restart , allowed_to_read
-
- REAL, DIMENSION( num_soil_layers), INTENT(INOUT) :: ZS, DZS
-
- REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , &
- INTENT(INOUT) :: SMOIS, & !Total soil moisture
- SH2O, & !liquid soil moisture
- TSLB !STEMP
-
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(INOUT) :: SNOW, &
- SNOWH, &
- SNOWC, &
- SNOALB, &
- CANWAT, &
- SMSTAV, &
- SMSTOT, &
- SFCRUNOFF, &
- UDRUNOFF, &
- ACSNOW, &
- VEGFRA, &
- ACSNOM
-
- INTEGER, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(IN) :: IVGTYP, &
- ISLTYP
- CHARACTER(LEN=*), INTENT(IN) :: MMINLU
-
- LOGICAL, INTENT(IN) :: FNDSOILW , &
- FNDSNOWH
- LOGICAL, INTENT(IN) :: RDMAXALB
-
-
- INTEGER :: L
- REAL :: BX, SMCMAX, PSISAT, FREE
- REAL, PARAMETER :: BLIM = 5.5, HLICE = 3.335E5, &
- GRAV = 9.81, T0 = 273.15
- INTEGER :: errflag
- CHARACTER(LEN=80) :: err_message
- INTEGER,DIMENSION(ims:ime, jms:jme ),INTENT(INOUT):: irr_rand_field
- INTEGER , DIMENSION(jds:jde) :: my_seeds
- INTEGER :: irr_ph,irr_freq
- REAL,DIMENSION(ims:ime, jms:jme ) :: rand_tmp
- character*256 :: MMINSL
- MMINSL='STAS'
-!
-
-! initialize three Noah LSM related tables
- IF ( allowed_to_read ) THEN
- CALL wrf_message( 'INITIALIZE THREE Noah LSM RELATED TABLES' )
- CALL SOIL_VEG_GEN_PARM( MMINLU, MMINSL )
- ENDIF
-
-! GAC-->
-! 20130219 - No longer need these - see module_data_gocart_dust
-!#if ( WRF_CHEM == 1 )
-!!
-!! need this parameter for dust parameterization in wrf/chem
-!!
-! do I=1,NSLTYPE
-! porosity(i)=maxsmc(i)
-! drypoint(i)=drysmc(i)
-! enddo
-!#endif
-! <--GAC
-
- IF(.not.restart)THEN
-
-#if ( EM_CORE==1 )
- IF (irr_ph.NE.0)THEN
- DO i = its,ite
- DO j=jts,jte
- my_seeds(j) =sqrt(ide*(real(j-1)**2))+sqrt(real(jde*i))
-! PRINT*,'myseed', my_seeds(j),j,jts,jds
- END DO
- CALL RANDOM_SEED ( PUT = my_seeds )
- CALL RANDOM_NUMBER ( rand_tmp(i,:) )
- CALL RANDOM_SEED ( GET = my_seeds )
- CALL RANDOM_NUMBER ( rand_tmp(i,:) )
- irr_rand_field(i,:)=int(modulo(rand_tmp(i,:)*100,real(irr_freq)))
- END DO
- END IF
-#endif
-
- itf=min0(ite,ide-1)
- jtf=min0(jte,jde-1)
-
- errflag = 0
- DO j = jts,jtf
- DO i = its,itf
- IF ( ISLTYP( i,j ) .LT. 1 ) THEN
- errflag = 1
- WRITE(err_message,*)"module_sf_noahdrv.F: lsminit: out of range ISLTYP ",i,j,ISLTYP( i,j )
- CALL wrf_message(err_message)
- ENDIF
- IF(.not.RDMAXALB) THEN
- SNOALB(i,j)=MAXALB(IVGTYP(i,j))*0.01
- ENDIF
- ENDDO
- ENDDO
- IF ( errflag .EQ. 1 ) THEN
-#if ( HWRF == 1 )
- CALL wrf_message( "WARNING: message only; was fatal. module_sf_noahdrv.F: lsminit: out of range value "// &
- "of ISLTYP. Is this field in the input?" )
-#else
- CALL wrf_error_fatal( "module_sf_noahdrv.F: lsminit: out of range value "// &
- "of ISLTYP. Is this field in the input?" )
-#endif
- ENDIF
-
-! initialize soil liquid water content SH2O
-
-! IF(.NOT.FNDSOILW) THEN
-
-! If no SWC, do the following
-! PRINT *,'SOIL WATER NOT FOUND - VALUE SET IN LSMINIT'
- DO J = jts,jtf
- DO I = its,itf
- BX = BB(ISLTYP(I,J))
- SMCMAX = MAXSMC(ISLTYP(I,J))
- PSISAT = SATPSI(ISLTYP(I,J))
- if ((bx > 0.0).and.(smcmax > 0.0).and.(psisat > 0.0)) then
- DO NS=1, num_soil_layers
-! ----------------------------------------------------------------------
-!SH2O <= SMOIS for T < 273.149K (-0.001C)
- IF (TSLB(I,NS,J) < 273.149) THEN
-! ----------------------------------------------------------------------
-! first guess following explicit solution for Flerchinger Eqn from Koren
-! et al, JGR, 1999, Eqn 17 (KCOUNT=0 in FUNCTION FRH2O).
-! ISLTPK is soil type
- BX = BB(ISLTYP(I,J))
- SMCMAX = MAXSMC(ISLTYP(I,J))
- PSISAT = SATPSI(ISLTYP(I,J))
- IF ( BX > BLIM ) BX = BLIM
- FK=(( (HLICE/(GRAV*(-PSISAT))) * &
- ((TSLB(I,NS,J)-T0)/TSLB(I,NS,J)) )**(-1/BX) )*SMCMAX
- IF (FK < 0.02) FK = 0.02
- SH2O(I,NS,J) = MIN( FK, SMOIS(I,NS,J) )
-! ----------------------------------------------------------------------
-! now use iterative solution for liquid soil water content using
-! FUNCTION FRH2O with the initial guess for SH2O from above explicit
-! first guess.
- CALL FRH2O (FREE,TSLB(I,NS,J),SMOIS(I,NS,J),SH2O(I,NS,J), &
- SMCMAX,BX,PSISAT)
- SH2O(I,NS,J) = FREE
- ELSE ! of IF (TSLB(I,NS,J)
-! ----------------------------------------------------------------------
-! SH2O = SMOIS ( for T => 273.149K (-0.001C)
- SH2O(I,NS,J)=SMOIS(I,NS,J)
-! ----------------------------------------------------------------------
- ENDIF ! of IF (TSLB(I,NS,J)
- END DO ! of DO NS=1, num_soil_layers
- else ! of if ((bx > 0.0)
- DO NS=1, num_soil_layers
- SH2O(I,NS,J)=SMOIS(I,NS,J)
- END DO
- endif ! of if ((bx > 0.0)
- ENDDO ! DO I = its,itf
- ENDDO ! DO J = jts,jtf
-! ENDIF ! of IF(.NOT.FNDSOILW)THEN
-
-! initialize physical snow height SNOWH
-
- IF(.NOT.FNDSNOWH)THEN
-! If no SNOWH do the following
- CALL wrf_message( 'SNOW HEIGHT NOT FOUND - VALUE DEFINED IN LSMINIT' )
- DO J = jts,jtf
- DO I = its,itf
- SNOWH(I,J)=SNOW(I,J)*0.005 ! SNOW in mm and SNOWH in m
- ENDDO
- ENDDO
- ENDIF
-
-! initialize canopy water to ZERO
-
-! GO TO 110
-! print*,'Note that canopy water content (CANWAT) is set to ZERO in LSMINIT'
- DO J = jts,jtf
- DO I = its,itf
- CANWAT(I,J)=0.0
- ENDDO
- ENDDO
- 110 CONTINUE
-
- ENDIF
-!------------------------------------------------------------------------------
- END SUBROUTINE lsminit
-!------------------------------------------------------------------------------
-
-
-
-!-----------------------------------------------------------------
- SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL)
-!-----------------------------------------------------------------
-
- USE module_wrf_error
- IMPLICIT NONE
-
- CHARACTER(LEN=*), INTENT(IN) :: MMINLU, MMINSL
- integer :: LUMATCH, IINDEX, LC, NUM_SLOPE
- integer :: ierr
- INTEGER , PARAMETER :: OPEN_OK = 0
-
- character*128 :: mess , message
- character*256 :: a_string
- logical, external :: wrf_dm_on_monitor
- integer , parameter :: loop_max = 10
- integer :: loop_count
-
-
-!-----SPECIFY VEGETATION RELATED CHARACTERISTICS :
-! ALBBCK: SFC albedo (in percentage)
-! Z0: Roughness length (m)
-! SHDFAC: Green vegetation fraction (in percentage)
-! Note: The ALBEDO, Z0, and SHDFAC values read from the following table
-! ALBEDO, amd Z0 are specified in LAND-USE TABLE; and SHDFAC is
-! the monthly green vegetation data
-! CMXTBL: MAX CNPY Capacity (m)
-! NROTBL: Rooting depth (layer)
-! RSMIN: Mimimum stomatal resistance (s m-1)
-! RSMAX: Max. stomatal resistance (s m-1)
-! RGL: Parameters used in radiation stress function
-! HS: Parameter used in vapor pressure deficit functio
-! TOPT: Optimum transpiration air temperature. (K)
-! CMCMAX: Maximum canopy water capacity
-! CFACTR: Parameter used in the canopy inteception calculati
-! SNUP: Threshold snow depth (in water equivalent m) that
-! implies 100% snow cover
-! LAI: Leaf area index (dimensionless)
-! MAXALB: Upper bound on maximum albedo over deep snow
-!
-!-----READ IN VEGETAION PROPERTIES FROM VEGPARM.TBL
-!
-
- IF ( wrf_dm_on_monitor() ) THEN
-
- OPEN(19, FILE='VEGPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr)
- IF(ierr .NE. OPEN_OK ) THEN
- WRITE(message,FMT='(A)') &
- 'module_sf_noahlsm.F: soil_veg_gen_parm: failure opening VEGPARM.TBL'
- CALL wrf_error_fatal ( message )
- END IF
-
-
- LUMATCH=0
-
- loop_count = 0
- READ (19,FMT='(A)',END=2002) a_string
- FIND_LUTYPE : DO WHILE (LUMATCH == 0)
- READ (19,*,END=2002)LUTYPE
- READ (19,*)LUCATS,IINDEX
-
- IF(LUTYPE.EQ.MMINLU)THEN
- WRITE( mess , * ) 'LANDUSE TYPE = ' // TRIM ( LUTYPE ) // ' FOUND', LUCATS,' CATEGORIES'
- CALL wrf_message( mess )
- LUMATCH=1
- ELSE
- loop_count = loop_count+1
- call wrf_message ( "Skipping over LUTYPE = " // TRIM ( LUTYPE ) )
- FIND_VEGETATION_PARAMETER_FLAG : DO
- READ (19,FMT='(A)', END=2002) a_string
- IF ( a_string(1:21) .EQ. 'Vegetation Parameters' ) THEN
- EXIT FIND_VEGETATION_PARAMETER_FLAG
- ELSE IF ( loop_count .GE. loop_max ) THEN
- CALL wrf_error_fatal ( 'Too many loops in VEGPARM.TBL')
- ENDIF
- ENDDO FIND_VEGETATION_PARAMETER_FLAG
- ENDIF
- ENDDO FIND_LUTYPE
-! prevent possible array overwrite, Bill Bovermann, IBM, May 6, 2008
- IF ( SIZE(SHDTBL) < LUCATS .OR. &
- SIZE(NROTBL) < LUCATS .OR. &
- SIZE(RSTBL) < LUCATS .OR. &
- SIZE(RGLTBL) < LUCATS .OR. &
- SIZE(HSTBL) < LUCATS .OR. &
- SIZE(SNUPTBL) < LUCATS .OR. &
- SIZE(MAXALB) < LUCATS .OR. &
- SIZE(LAIMINTBL) < LUCATS .OR. &
- SIZE(LAIMAXTBL) < LUCATS .OR. &
- SIZE(Z0MINTBL) < LUCATS .OR. &
- SIZE(Z0MAXTBL) < LUCATS .OR. &
- SIZE(ALBEDOMINTBL) < LUCATS .OR. &
- SIZE(ALBEDOMAXTBL) < LUCATS .OR. &
- SIZE(ZTOPVTBL) < LUCATS .OR. &
- SIZE(ZBOTVTBL) < LUCATS .OR. &
- SIZE(EMISSMINTBL ) < LUCATS .OR. &
- SIZE(EMISSMAXTBL ) < LUCATS ) THEN
- CALL wrf_error_fatal('Table sizes too small for value of LUCATS in module_sf_noahdrv.F')
- ENDIF
-
- IF(LUTYPE.EQ.MMINLU)THEN
- DO LC=1,LUCATS
- READ (19,*)IINDEX,SHDTBL(LC), &
- NROTBL(LC),RSTBL(LC),RGLTBL(LC),HSTBL(LC), &
- SNUPTBL(LC),MAXALB(LC), LAIMINTBL(LC), &
- LAIMAXTBL(LC),EMISSMINTBL(LC), &
- EMISSMAXTBL(LC), ALBEDOMINTBL(LC), &
- ALBEDOMAXTBL(LC), Z0MINTBL(LC), Z0MAXTBL(LC),&
- ZTOPVTBL(LC), ZBOTVTBL(LC)
- ENDDO
-!
- READ (19,*)
- READ (19,*)TOPT_DATA
- READ (19,*)
- READ (19,*)CMCMAX_DATA
- READ (19,*)
- READ (19,*)CFACTR_DATA
- READ (19,*)
- READ (19,*)RSMAX_DATA
- READ (19,*)
- READ (19,*)BARE
- READ (19,*)
- READ (19,*)NATURAL
- READ (19,*)
- READ (19,*)
- READ (19,FMT='(A)') a_string
- IF ( a_string(1:21) .EQ. 'Vegetation Parameters' ) THEN
- CALL wrf_message ("Expected low and high density residential, and high density industrial information in VEGPARM.TBL")
- CALL wrf_error_fatal ("This could be caused by using an older VEGPARM.TBL file with a newer WRF source code.")
- ENDIF
- READ (19,*)LCZ_1
- READ (19,*)
- READ (19,*)LCZ_2
- READ (19,*)
- READ (19,*)LCZ_3
- IF(LUTYPE.NE.MMINLU)THEN
- READ (19,*)
- READ (19,*)LCZ_4
- READ (19,*)
- READ (19,*)LCZ_5
- READ (19,*)
- READ (19,*)LCZ_6
- READ (19,*)
- READ (19,*)LCZ_7
- READ (19,*)
- READ (19,*)LCZ_8
- READ (19,*)
- READ (19,*)LCZ_9
- READ (19,*)
- READ (19,*)LCZ_10
- READ (19,*)
- READ (19,*)LCZ_11
- END IF
- ENDIF
- 2002 CONTINUE
-
- CLOSE (19)
- IF (LUMATCH == 0) then
- CALL wrf_error_fatal ("Land Use Dataset '"//MMINLU//"' not found in VEGPARM.TBL.")
- ENDIF
- ENDIF
-
- CALL wrf_dm_bcast_string ( LUTYPE , 4 )
- CALL wrf_dm_bcast_integer ( LUCATS , 1 )
- CALL wrf_dm_bcast_integer ( IINDEX , 1 )
- CALL wrf_dm_bcast_integer ( LUMATCH , 1 )
- CALL wrf_dm_bcast_real ( SHDTBL , NLUS )
- CALL wrf_dm_bcast_real ( NROTBL , NLUS )
- CALL wrf_dm_bcast_real ( RSTBL , NLUS )
- CALL wrf_dm_bcast_real ( RGLTBL , NLUS )
- CALL wrf_dm_bcast_real ( HSTBL , NLUS )
- CALL wrf_dm_bcast_real ( SNUPTBL , NLUS )
- CALL wrf_dm_bcast_real ( LAIMINTBL , NLUS )
- CALL wrf_dm_bcast_real ( LAIMAXTBL , NLUS )
- CALL wrf_dm_bcast_real ( Z0MINTBL , NLUS )
- CALL wrf_dm_bcast_real ( Z0MAXTBL , NLUS )
- CALL wrf_dm_bcast_real ( EMISSMINTBL , NLUS )
- CALL wrf_dm_bcast_real ( EMISSMAXTBL , NLUS )
- CALL wrf_dm_bcast_real ( ALBEDOMINTBL , NLUS )
- CALL wrf_dm_bcast_real ( ALBEDOMAXTBL , NLUS )
- CALL wrf_dm_bcast_real ( ZTOPVTBL , NLUS )
- CALL wrf_dm_bcast_real ( ZBOTVTBL , NLUS )
- CALL wrf_dm_bcast_real ( MAXALB , NLUS )
- CALL wrf_dm_bcast_real ( TOPT_DATA , 1 )
- CALL wrf_dm_bcast_real ( CMCMAX_DATA , 1 )
- CALL wrf_dm_bcast_real ( CFACTR_DATA , 1 )
- CALL wrf_dm_bcast_real ( RSMAX_DATA , 1 )
- CALL wrf_dm_bcast_integer ( BARE , 1 )
- CALL wrf_dm_bcast_integer ( NATURAL , 1 )
- CALL wrf_dm_bcast_integer ( LCZ_1 , 1 )
- CALL wrf_dm_bcast_integer ( LCZ_2 , 1 )
- CALL wrf_dm_bcast_integer ( LCZ_3 , 1 )
- CALL wrf_dm_bcast_integer ( LCZ_4 , 1 )
- CALL wrf_dm_bcast_integer ( LCZ_5 , 1 )
- CALL wrf_dm_bcast_integer ( LCZ_6 , 1 )
- CALL wrf_dm_bcast_integer ( LCZ_7 , 1 )
- CALL wrf_dm_bcast_integer ( LCZ_8 , 1 )
- CALL wrf_dm_bcast_integer ( LCZ_9 , 1 )
- CALL wrf_dm_bcast_integer ( LCZ_10 , 1 )
- CALL wrf_dm_bcast_integer ( LCZ_11 , 1 )
-
-!
-!-----READ IN SOIL PROPERTIES FROM SOILPARM.TBL
-!
- IF ( wrf_dm_on_monitor() ) THEN
- OPEN(19, FILE='SOILPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr)
- IF(ierr .NE. OPEN_OK ) THEN
- WRITE(message,FMT='(A)') &
- 'module_sf_noahlsm.F: soil_veg_gen_parm: failure opening SOILPARM.TBL'
- CALL wrf_error_fatal ( message )
- END IF
-
- WRITE(mess,*) 'INPUT SOIL TEXTURE CLASSIFICATION = ', TRIM ( MMINSL )
- CALL wrf_message( mess )
-
- LUMATCH=0
-
- READ (19,*)
- READ (19,2000,END=2003)SLTYPE
- 2000 FORMAT (A4)
- READ (19,*)SLCATS,IINDEX
- IF(SLTYPE.EQ.MMINSL)THEN
- WRITE( mess , * ) 'SOIL TEXTURE CLASSIFICATION = ', TRIM ( SLTYPE ) , ' FOUND', &
- SLCATS,' CATEGORIES'
- CALL wrf_message ( mess )
- LUMATCH=1
- ENDIF
-! prevent possible array overwrite, Bill Bovermann, IBM, May 6, 2008
- IF ( SIZE(BB ) < SLCATS .OR. &
- SIZE(DRYSMC) < SLCATS .OR. &
- SIZE(F11 ) < SLCATS .OR. &
- SIZE(MAXSMC) < SLCATS .OR. &
- SIZE(REFSMC) < SLCATS .OR. &
- SIZE(SATPSI) < SLCATS .OR. &
- SIZE(SATDK ) < SLCATS .OR. &
- SIZE(SATDW ) < SLCATS .OR. &
- SIZE(WLTSMC) < SLCATS .OR. &
- SIZE(QTZ ) < SLCATS ) THEN
- CALL wrf_error_fatal('Table sizes too small for value of SLCATS in module_sf_noahdrv.F')
- ENDIF
- IF(SLTYPE.EQ.MMINSL)THEN
- DO LC=1,SLCATS
- READ (19,*) IINDEX,BB(LC),DRYSMC(LC),F11(LC),MAXSMC(LC),&
- REFSMC(LC),SATPSI(LC),SATDK(LC), SATDW(LC), &
- WLTSMC(LC), QTZ(LC)
- ENDDO
- ENDIF
-
- 2003 CONTINUE
-
- CLOSE (19)
- ENDIF
-
- CALL wrf_dm_bcast_integer ( LUMATCH , 1 )
- CALL wrf_dm_bcast_string ( SLTYPE , 4 )
- CALL wrf_dm_bcast_string ( MMINSL , 4 ) ! since this is reset above, see oct2 ^
- CALL wrf_dm_bcast_integer ( SLCATS , 1 )
- CALL wrf_dm_bcast_integer ( IINDEX , 1 )
- CALL wrf_dm_bcast_real ( BB , NSLTYPE )
- CALL wrf_dm_bcast_real ( DRYSMC , NSLTYPE )
- CALL wrf_dm_bcast_real ( F11 , NSLTYPE )
- CALL wrf_dm_bcast_real ( MAXSMC , NSLTYPE )
- CALL wrf_dm_bcast_real ( REFSMC , NSLTYPE )
- CALL wrf_dm_bcast_real ( SATPSI , NSLTYPE )
- CALL wrf_dm_bcast_real ( SATDK , NSLTYPE )
- CALL wrf_dm_bcast_real ( SATDW , NSLTYPE )
- CALL wrf_dm_bcast_real ( WLTSMC , NSLTYPE )
- CALL wrf_dm_bcast_real ( QTZ , NSLTYPE )
-
- IF(LUMATCH.EQ.0)THEN
- CALL wrf_message( 'SOIl TEXTURE IN INPUT FILE DOES NOT ' )
- CALL wrf_message( 'MATCH SOILPARM TABLE' )
- CALL wrf_error_fatal ( 'INCONSISTENT OR MISSING SOILPARM FILE' )
- ENDIF
-
-!
-!-----READ IN GENERAL PARAMETERS FROM GENPARM.TBL
-!
- IF ( wrf_dm_on_monitor() ) THEN
- OPEN(19, FILE='GENPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr)
- IF(ierr .NE. OPEN_OK ) THEN
- WRITE(message,FMT='(A)') &
- 'module_sf_noahlsm.F: soil_veg_gen_parm: failure opening GENPARM.TBL'
- CALL wrf_error_fatal ( message )
- END IF
-
- READ (19,*)
- READ (19,*)
- READ (19,*) NUM_SLOPE
-
- SLPCATS=NUM_SLOPE
-! prevent possible array overwrite, Bill Bovermann, IBM, May 6, 2008
- IF ( SIZE(slope_data) < NUM_SLOPE ) THEN
- CALL wrf_error_fatal('NUM_SLOPE too large for slope_data array in module_sf_noahdrv')
- ENDIF
-
- DO LC=1,SLPCATS
- READ (19,*)SLOPE_DATA(LC)
- ENDDO
-
- READ (19,*)
- READ (19,*)SBETA_DATA
- READ (19,*)
- READ (19,*)FXEXP_DATA
- READ (19,*)
- READ (19,*)CSOIL_DATA
- READ (19,*)
- READ (19,*)SALP_DATA
- READ (19,*)
- READ (19,*)REFDK_DATA
- READ (19,*)
- READ (19,*)REFKDT_DATA
- READ (19,*)
- READ (19,*)FRZK_DATA
- READ (19,*)
- READ (19,*)ZBOT_DATA
- READ (19,*)
- READ (19,*)CZIL_DATA
- READ (19,*)
- READ (19,*)SMLOW_DATA
- READ (19,*)
- READ (19,*)SMHIGH_DATA
- READ (19,*)
- READ (19,*)LVCOEF_DATA
- CLOSE (19)
- ENDIF
-
- CALL wrf_dm_bcast_integer ( NUM_SLOPE , 1 )
- CALL wrf_dm_bcast_integer ( SLPCATS , 1 )
- CALL wrf_dm_bcast_real ( SLOPE_DATA , NSLOPE )
- CALL wrf_dm_bcast_real ( SBETA_DATA , 1 )
- CALL wrf_dm_bcast_real ( FXEXP_DATA , 1 )
- CALL wrf_dm_bcast_real ( CSOIL_DATA , 1 )
- CALL wrf_dm_bcast_real ( SALP_DATA , 1 )
- CALL wrf_dm_bcast_real ( REFDK_DATA , 1 )
- CALL wrf_dm_bcast_real ( REFKDT_DATA , 1 )
- CALL wrf_dm_bcast_real ( FRZK_DATA , 1 )
- CALL wrf_dm_bcast_real ( ZBOT_DATA , 1 )
- CALL wrf_dm_bcast_real ( CZIL_DATA , 1 )
- CALL wrf_dm_bcast_real ( SMLOW_DATA , 1 )
- CALL wrf_dm_bcast_real ( SMHIGH_DATA , 1 )
- CALL wrf_dm_bcast_real ( LVCOEF_DATA , 1 )
-
-
-!-----------------------------------------------------------------
- END SUBROUTINE SOIL_VEG_GEN_PARM
-!-----------------------------------------------------------------
-
-!===========================================================================
-!
-! subroutine lsm_mosaic: a tiling approach for Noah LSM
-!
-!===========================================================================
-
-SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, &
- HFX,QFX,LH,GRDFLX, QGH,GSW,SWDOWN,GLW,SMSTAV,SMSTOT, &
- SFCRUNOFF, UDRUNOFF,IVGTYP,ISLTYP,ISURBAN,ISICE,VEGFRA, &
- ALBEDO,ALBBCK,ZNT,Z0,TMN,XLAND,XICE,EMISS,EMBCK, &
- SNOWC,QSFC,RAINBL,MMINLU, &
- num_soil_layers,DT,DZS,ITIMESTEP, &
- SMOIS,TSLB,SNOW,CANWAT, &
- CHS,CHS2,CQS2,CPM,ROVCP,SR,chklowq,lai,qz0, & !H
- myj,frpcpn, &
- SH2O,SNOWH, & !H
- U_PHY,V_PHY, & !I
- SNOALB,SHDMIN,SHDMAX, & !I
- SNOTIME, & !?
- ACSNOM,ACSNOW, & !O
- SNOPCX, & !O
- POTEVP, & !O
- SMCREL, & !O
- XICE_THRESHOLD, &
- RDLAI2D,USEMONALB, &
- RIB, & !?
- NOAHRES,OPT_THCND, &
- NLCAT,landusef,landusef2, & ! danli mosaic
- sf_surface_mosaic,mosaic_cat,mosaic_cat_index, & ! danli mosaic
- TSK_mosaic,QSFC_mosaic, & ! danli mosaic
- TSLB_mosaic,SMOIS_mosaic,SH2O_mosaic, & ! danli mosaic
- CANWAT_mosaic,SNOW_mosaic, & ! danli mosaic
- SNOWH_mosaic,SNOWC_mosaic, & ! danli mosaic
- ALBEDO_mosaic,ALBBCK_mosaic, & ! danli mosaic
- EMISS_mosaic, EMBCK_mosaic, & ! danli mosaic
- ZNT_mosaic, Z0_mosaic, & ! danli mosaic
- HFX_mosaic,QFX_mosaic, & ! danli mosaic
- LH_mosaic, GRDFLX_mosaic, SNOTIME_mosaic, & ! danli mosaic
- RC_mosaic, LAI_mosaic, &
-! Noah UA changes
- ua_phys,flx4_2d,fvb_2d,fbur_2d,fgsn_2d, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte, &
- sf_urban_physics, &
- CMR_SFCDIF,CHR_SFCDIF,CMC_SFCDIF,CHC_SFCDIF, &
- CMGR_SFCDIF,CHGR_SFCDIF, &
-!Optional Urban
- TR_URB2D,TB_URB2D,TG_URB2D,TC_URB2D,QC_URB2D, & !H urban
- UC_URB2D, & !H urban
- XXXR_URB2D,XXXB_URB2D,XXXG_URB2D,XXXC_URB2D, & !H urban
- TRL_URB3D,TBL_URB3D,TGL_URB3D, & !H urban
- SH_URB2D,LH_URB2D,G_URB2D,RN_URB2D,TS_URB2D, & !H urban
- TR_URB2D_mosaic,TB_URB2D_mosaic, & !H urban danli mosaic
- TG_URB2D_mosaic,TC_URB2D_mosaic, & !H urban danli mosaic
- QC_URB2D_mosaic,UC_URB2D_mosaic, & !H urban danli mosaic
- TRL_URB3D_mosaic,TBL_URB3D_mosaic, & !H urban danli mosaic
- TGL_URB3D_mosaic, & !H urban danli mosaic
- SH_URB2D_mosaic,LH_URB2D_mosaic, & !H urban danli mosaic
- G_URB2D_mosaic,RN_URB2D_mosaic, & !H urban danli mosaic
- TS_URB2D_mosaic, & !H urban danli mosaic
- TS_RUL2D_mosaic, & !H urban danli mosaic
- PSIM_URB2D,PSIH_URB2D,U10_URB2D,V10_URB2D, & !O urban
- GZ1OZ0_URB2D, AKMS_URB2D, & !O urban
- TH2_URB2D,Q2_URB2D, UST_URB2D, & !O urban
- DECLIN_URB,COSZ_URB2D,OMG_URB2D, & !I urban
- XLAT_URB2D, & !I urban
- num_roof_layers, num_wall_layers, & !I urban
- num_road_layers, DZR, DZB, DZG, & !I urban
- CMCR_URB2D,TGR_URB2D,TGRL_URB3D,SMR_URB3D, & !H urban
- julian,julyr, & !H urban
- DRELR_URB2D,DRELB_URB2D,DRELG_URB2D, & !H urban
- FLXHUMR_URB2D,FLXHUMB_URB2D,FLXHUMG_URB2D, & !H urban
- FRC_URB2D,UTYPE_URB2D, & !O
- num_urban_ndm, & !I multi-layer urban
- urban_map_zrd, & !I multi-layer urban
- urban_map_zwd, & !I multi-layer urban
- urban_map_gd, & !I multi-layer urban
- urban_map_zd, & !I multi-layer urban
- urban_map_zdf, & !I multi-layer urban
- urban_map_bd, & !I multi-layer urban
- urban_map_wd, & !I multi-layer urban
- urban_map_gbd, & !I multi-layer urban
- urban_map_fbd, & !I multi-layer urban
- urban_map_zgrd, & !I multi-layer urban
- num_urban_hi, & !I multi-layer urban
- tsk_rural_bep, & !H multi-layer urban
- trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, & !H multi-layer urban
- tlev_urb3d,qlev_urb3d, & !H multi-layer urban
- tw1lev_urb3d,tw2lev_urb3d, & !H multi-layer urban
- tglev_urb3d,tflev_urb3d, & !H multi-layer urban
- sf_ac_urb3d,lf_ac_urb3d,cm_ac_urb3d, & !H multi-layer urban
- sfvent_urb3d,lfvent_urb3d, & !H multi-layer urban
- sfwin1_urb3d,sfwin2_urb3d, & !H multi-layer urban
- sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d, & !H multi-layer urban
- ep_pv_urb3d,t_pv_urb3d, & !RMS
- trv_urb4d,qr_urb4d,qgr_urb3d,tgr_urb3d, & !RMS
- drain_urb4d,draingr_urb3d,sfrv_urb3d, & !RMS
- lfrv_urb3d,dgr_urb3d,dg_urb3d,lfr_urb3d,lfg_urb3d,& !RMS
- lp_urb2d,hi_urb2d,lb_urb2d,hgt_urb2d, & !H multi-layer urban
- mh_urb2d,stdh_urb2d,lf_urb2d, & !SLUCM
- th_phy,rho,p_phy,ust, & !I multi-layer urban
- gmt,julday,xlong,xlat, & !I multi-layer urban
- a_u_bep,a_v_bep,a_t_bep,a_q_bep, & !O multi-layer urban
- a_e_bep,b_u_bep,b_v_bep, & !O multi-layer urban
- b_t_bep,b_q_bep,b_e_bep,dlg_bep, & !O multi-layer urban
- dl_u_bep,sf_bep,vl_bep & !O multi-layer urban
- ,sfcheadrt,INFXSRT, soldrain & !hydro
- ,SDA_HFX, SDA_QFX, HFX_BOTH, QFX_BOTH, QNORM, fasdas & !fasdas
- ,RC2,XLAI2 & !O
- ,IRR_CHAN &
- )
-
-!----------------------------------------------------------------
- IMPLICIT NONE
-!----------------------------------------------------------------
-!----------------------------------------------------------------
-! --- atmospheric (WRF generic) variables
-!-- DT time step (seconds)
-!-- DZ8W thickness of layers (m)
-!-- T3D temperature (K)
-!-- QV3D 3D water vapor mixing ratio (Kg/Kg)
-!-- P3D 3D pressure (Pa)
-!-- FLHC exchange coefficient for heat (m/s)
-!-- FLQC exchange coefficient for moisture (m/s)
-!-- PSFC surface pressure (Pa)
-!-- XLAND land mask (1 for land, 2 for water)
-!-- QGH saturated mixing ratio at 2 meter
-!-- GSW downward short wave flux at ground surface (W/m^2)
-!-- GLW downward long wave flux at ground surface (W/m^2)
-!-- History variables
-!-- CANWAT canopy moisture content (mm)
-!-- TSK surface temperature (K)
-!-- TSLB soil temp (k)
-!-- SMOIS total soil moisture content (volumetric fraction)
-!-- SH2O unfrozen soil moisture content (volumetric fraction)
-! note: frozen soil moisture (i.e., soil ice) = SMOIS - SH2O
-!-- SNOWH actual snow depth (m)
-!-- SNOW liquid water-equivalent snow depth (m)
-!-- ALBEDO time-varying surface albedo including snow effect (unitless fraction)
-!-- ALBBCK background surface albedo (unitless fraction)
-!-- CHS surface exchange coefficient for heat and moisture (m s-1);
-!-- CHS2 2m surface exchange coefficient for heat (m s-1);
-!-- CQS2 2m surface exchange coefficient for moisture (m s-1);
-! --- soil variables
-!-- num_soil_layers the number of soil layers
-!-- ZS depths of centers of soil layers (m)
-!-- DZS thicknesses of soil layers (m)
-!-- SLDPTH thickness of each soil layer (m, same as DZS)
-!-- TMN soil temperature at lower boundary (K)
-!-- SMCWLT wilting point (volumetric)
-!-- SMCDRY dry soil moisture threshold where direct evap from
-! top soil layer ends (volumetric)
-!-- SMCREF soil moisture threshold below which transpiration begins to
-! stress (volumetric)
-!-- SMCMAX porosity, i.e. saturated value of soil moisture (volumetric)
-!-- NROOT number of root layers, a function of veg type, determined
-! in subroutine redprm.
-!-- SMSTAV Soil moisture availability for evapotranspiration (
-! fraction between SMCWLT and SMCMXA)
-!-- SMSTOT Total soil moisture content frozen+unfrozen) in the soil column (mm)
-! --- snow variables
-!-- SNOWC fraction snow coverage (0-1.0)
-! --- vegetation variables
-!-- SNOALB upper bound on maximum albedo over deep snow
-!-- SHDMIN minimum areal fractional coverage of annual green vegetation
-!-- SHDMAX maximum areal fractional coverage of annual green vegetation
-!-- XLAI leaf area index (dimensionless)
-!-- Z0BRD Background fixed roughness length (M)
-!-- Z0 Background vroughness length (M) as function
-!-- ZNT Time varying roughness length (M) as function
-!-- ALBD(IVGTPK,ISN) background albedo reading from a table
-! --- LSM output
-!-- HFX upward heat flux at the surface (W/m^2)
-!-- QFX upward moisture flux at the surface (kg/m^2/s)
-!-- LH upward moisture flux at the surface (W m-2)
-!-- GRDFLX(I,J) ground heat flux (W m-2)
-!-- FDOWN radiation forcing at the surface (W m-2) = SOLDN*(1-alb)+LWDN
-!----------------------------------------------------------------------------
-!-- EC canopy water evaporation ((W m-2)
-!-- EDIR direct soil evaporation (W m-2)
-!-- ET plant transpiration from a particular root layer (W m-2)
-!-- ETT total plant transpiration (W m-2)
-!-- ESNOW sublimation from (or deposition to if <0) snowpack (W m-2)
-!-- DRIP through-fall of precip and/or dew in excess of canopy
-! water-holding capacity (m)
-!-- DEW dewfall (or frostfall for t<273.15) (M)
-!-- SMAV Soil Moisture Availability for each layer, as a fraction
-! between SMCWLT and SMCMAX (dimensionless fraction)
-! ----------------------------------------------------------------------
-!-- BETA ratio of actual/potential evap (dimensionless)
-!-- ETP potential evaporation (W m-2)
-! ----------------------------------------------------------------------
-!-- FLX1 precip-snow sfc (W m-2)
-!-- FLX2 freezing rain latent heat flux (W m-2)
-!-- FLX3 phase-change heat flux from snowmelt (W m-2)
-! ----------------------------------------------------------------------
-!-- ACSNOM snow melt (mm) (water equivalent)
-!-- ACSNOW accumulated snow fall (mm) (water equivalent)
-!-- SNOPCX snow phase change heat flux (W/m^2)
-!-- POTEVP accumulated potential evaporation (m)
-!-- RIB Documentation needed!!!
-! ----------------------------------------------------------------------
-!-- RUNOFF1 surface runoff (m s-1), not infiltrating the surface
-!-- RUNOFF2 subsurface runoff (m s-1), drainage out bottom of last
-! soil layer (baseflow)
-! important note: here RUNOFF2 is actually the sum of RUNOFF2 and RUNOFF3
-!-- RUNOFF3 numerical trunctation in excess of porosity (smcmax)
-! for a given soil layer at the end of a time step (m s-1).
-!SFCRUNOFF Surface Runoff (mm)
-!UDRUNOFF Total Underground Runoff (mm), which is the sum of RUNOFF2 and RUNOFF3
-! ----------------------------------------------------------------------
-!-- RC canopy resistance (s m-1)
-!-- PC plant coefficient (unitless fraction, 0-1) where PC*ETP = actual transp
-!-- RSMIN minimum canopy resistance (s m-1)
-!-- RCS incoming solar rc factor (dimensionless)
-!-- RCT air temperature rc factor (dimensionless)
-!-- RCQ atmos vapor pressure deficit rc factor (dimensionless)
-!-- RCSOIL soil moisture rc factor (dimensionless)
-
-!-- EMISS surface emissivity (between 0 and 1)
-!-- EMBCK Background surface emissivity (between 0 and 1)
-
-!-- ROVCP R/CP
-! (R_d/R_v) (dimensionless)
-!-- ids start index for i in domain
-!-- ide end index for i in domain
-!-- jds start index for j in domain
-!-- jde end index for j in domain
-!-- kds start index for k in domain
-!-- kde end index for k in domain
-!-- ims start index for i in memory
-!-- ime end index for i in memory
-!-- jms start index for j in memory
-!-- jme end index for j in memory
-!-- kms start index for k in memory
-!-- kme end index for k in memory
-!-- its start index for i in tile
-!-- ite end index for i in tile
-!-- jts start index for j in tile
-!-- jte end index for j in tile
-!-- kts start index for k in tile
-!-- kte end index for k in tile
-!
-!-- SR fraction of frozen precip (0.0 to 1.0)
-!----------------------------------------------------------------
-
-! IN only
-
- INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte
-
- INTEGER, INTENT(IN ) :: sf_urban_physics !urban
- INTEGER, INTENT(IN ) :: isurban
- INTEGER, INTENT(IN ) :: isice
- INTEGER, INTENT(IN ) :: julian,julyr
-
-!added by Wei Yu for routing
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(INOUT) :: sfcheadrt,INFXSRT,soldrain
- real :: etpnd1
-!end added
-
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(IN ) :: TMN, &
- XLAND, &
- XICE, &
- VEGFRA, &
- SHDMIN, &
- SHDMAX, &
- SNOALB, &
- GSW, &
- SWDOWN, & !added 10 jan 2007
- GLW, &
- RAINBL, &
- SR
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(INOUT) :: ALBBCK, &
- Z0, &
- EMBCK ! danli mosaic
-
- CHARACTER(LEN=*), INTENT(IN ) :: MMINLU
-
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
- INTENT(IN ) :: QV3D, &
- p8w3D, &
- DZ8W, &
- T3D
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(IN ) :: QGH, &
- CPM
-
- INTEGER, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(IN ) :: ISLTYP
-
- INTEGER, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(INOUT ) :: IVGTYP ! for mosaic danli
-
- INTEGER, INTENT(IN) :: num_soil_layers,ITIMESTEP
-
- REAL, INTENT(IN ) :: DT,ROVCP
-
- REAL, DIMENSION(1:num_soil_layers), INTENT(IN)::DZS
-
-! IN and OUT
-
- REAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), &
- INTENT(INOUT) :: SMOIS, & ! total soil moisture
- SH2O, & ! new soil liquid
- TSLB ! TSLB STEMP
-
- REAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), &
- INTENT(OUT) :: SMCREL
-
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(INOUT) :: TSK, & !was TGB (temperature)
- HFX, &
- QFX, &
- LH, &
- GRDFLX, &
- QSFC,&
- CQS2,&
- CHS, &
- CHS2,&
- SNOW, &
- SNOWC, &
- SNOWH, & !new
- CANWAT, &
- SMSTAV, &
- SMSTOT, &
- SFCRUNOFF, &
- UDRUNOFF, &
- ACSNOM, &
- ACSNOW, &
- SNOTIME, &
- SNOPCX, &
- EMISS, &
- RIB, &
- POTEVP, &
- ALBEDO, &
- ZNT
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(OUT) :: NOAHRES
- INTEGER, INTENT(IN) :: OPT_THCND
-
-! Noah UA changes
- LOGICAL, INTENT(IN) :: UA_PHYS
- REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: FLX4_2D,FVB_2D,FBUR_2D,FGSN_2D
- REAL :: FLX4,FVB,FBUR,FGSN
-
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(OUT) :: CHKLOWQ
- REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LAI
- REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: QZ0
- REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: RC2, XLAI2
-
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMR_SFCDIF
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHR_SFCDIF
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMGR_SFCDIF
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHGR_SFCDIF
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMC_SFCDIF
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHC_SFCDIF
-! Local variables (moved here from driver to make routine thread safe, 20031007 jm)
-
- REAL, DIMENSION(1:num_soil_layers) :: ET
-
- REAL, DIMENSION(1:num_soil_layers) :: SMAV
-
- REAL :: BETA, ETP, SSOIL,EC, EDIR, ESNOW, ETT, &
- FLX1,FLX2,FLX3, DRIP,DEW,FDOWN,RC,PC,RSMIN,XLAI, &
-! RCS,RCT,RCQ,RCSOIL
- RCS,RCT,RCQ,RCSOIL,FFROZP
-
- LOGICAL, INTENT(IN ) :: myj,frpcpn
-
-! DECLARATIONS - LOGICAL
-! ----------------------------------------------------------------------
- LOGICAL, PARAMETER :: LOCAL=.false.
- LOGICAL :: FRZGRA, SNOWNG
-
- LOGICAL :: IPRINT
-
-! ----------------------------------------------------------------------
-! DECLARATIONS - INTEGER
-! ----------------------------------------------------------------------
- INTEGER :: I,J, ICE,NSOIL,SLOPETYP,SOILTYP,VEGTYP
- INTEGER :: NROOT
- INTEGER :: KZ ,K
- INTEGER :: NS
-! ----------------------------------------------------------------------
-! DECLARATIONS - REAL
-! ----------------------------------------------------------------------
-
- REAL :: SHMIN,SHMAX,DQSDT2,LWDN,PRCP,PRCPRAIN, &
- Q2SAT,Q2SATI,SFCPRS,SFCSPD,SFCTMP,SHDFAC,SNOALB1, &
- SOLDN,TBOT,ZLVL, Q2K,ALBBRD, ALBEDOK, ETA, ETA_KINEMATIC, &
- EMBRD, &
- Z0K,RUNOFF1,RUNOFF2,RUNOFF3,SHEAT,SOLNET,E2SAT,SFCTSNO, &
-! mek, WRF testing, expanded diagnostics
- SOLUP,LWUP,RNET,RES,Q1SFC,TAIRV,SATFLG
-! MEK MAY 2007
- REAL :: FDTLIW
-! MEK JUL2007 for pot. evap.
- REAL :: RIBB
- REAL :: FDTW
-
- REAL :: EMISSI
-
- REAL :: SNCOVR,SNEQV,SNOWHK,CMC, CHK,TH2
-
- REAL :: SMCDRY,SMCMAX,SMCREF,SMCWLT,SNOMLT,SOILM,SOILW,Q1,T1
- REAL :: SNOTIME1 ! LSTSNW1 INITIAL NUMBER OF TIMESTEPS SINCE LAST SNOWFALL
-
- REAL :: DUMMY,Z0BRD
-!
- REAL :: COSZ, SOLARDIRECT
-!
- REAL, DIMENSION(1:num_soil_layers):: SLDPTH, STC,SMC,SWC
-!
- REAL, DIMENSION(1:num_soil_layers) :: ZSOIL, RTDIS
- REAL, PARAMETER :: TRESH=.95E0, A2=17.67,A3=273.15,A4=29.65, &
- T0=273.16E0, ELWV=2.50E6, A23M4=A2*(A3-A4)
-! MEK MAY 2007
- REAL, PARAMETER :: ROW=1.E3,ELIW=XLF,ROWLIW=ROW*ELIW
-
-! ----------------------------------------------------------------------
-! DECLARATIONS START - urban
-! ----------------------------------------------------------------------
-
-! input variables surface_driver --> lsm
- INTEGER, INTENT(IN) :: num_roof_layers
- INTEGER, INTENT(IN) :: num_wall_layers
- INTEGER, INTENT(IN) :: num_road_layers
- REAL, OPTIONAL, DIMENSION(1:num_roof_layers), INTENT(IN) :: DZR
- REAL, OPTIONAL, DIMENSION(1:num_wall_layers), INTENT(IN) :: DZB
- REAL, OPTIONAL, DIMENSION(1:num_road_layers), INTENT(IN) :: DZG
- REAL, OPTIONAL, INTENT(IN) :: DECLIN_URB
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: COSZ_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: OMG_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: XLAT_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: U_PHY
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: V_PHY
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: TH_PHY
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: P_PHY
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: RHO
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UST
-
- LOGICAL, intent(in) :: rdlai2d
- LOGICAL, intent(in) :: USEMONALB
-
-! input variables lsm --> urban
- INTEGER :: UTYPE_URB ! urban type [urban=1, suburban=2, rural=3]
- REAL :: TA_URB ! potential temp at 1st atmospheric level [K]
- REAL :: QA_URB ! mixing ratio at 1st atmospheric level [kg/kg]
- REAL :: UA_URB ! wind speed at 1st atmospheric level [m/s]
- REAL :: U1_URB ! u at 1st atmospheric level [m/s]
- REAL :: V1_URB ! v at 1st atmospheric level [m/s]
- REAL :: SSG_URB ! downward total short wave radiation [W/m/m]
- REAL :: LLG_URB ! downward long wave radiation [W/m/m]
- REAL :: RAIN_URB ! precipitation [mm/h]
- REAL :: RHOO_URB ! air density [kg/m^3]
- REAL :: ZA_URB ! first atmospheric level [m]
- REAL :: DELT_URB ! time step [s]
- REAL :: SSGD_URB ! downward direct short wave radiation [W/m/m]
- REAL :: SSGQ_URB ! downward diffuse short wave radiation [W/m/m]
- REAL :: XLAT_URB ! latitude [deg]
- REAL :: COSZ_URB ! cosz
- REAL :: OMG_URB ! hour angle
- REAL :: ZNT_URB ! roughness length [m]
- REAL :: TR_URB
- REAL :: TB_URB
- REAL :: TG_URB
- REAL :: TC_URB
- REAL :: QC_URB
- REAL :: UC_URB
- REAL :: XXXR_URB
- REAL :: XXXB_URB
- REAL :: XXXG_URB
- REAL :: XXXC_URB
- REAL, DIMENSION(1:num_roof_layers) :: TRL_URB ! roof layer temp [K]
- REAL, DIMENSION(1:num_wall_layers) :: TBL_URB ! wall layer temp [K]
- REAL, DIMENSION(1:num_road_layers) :: TGL_URB ! road layer temp [K]
- LOGICAL :: LSOLAR_URB
-
-!===Yang,2014/10/08,hydrological variable for single layer UCM===
- INTEGER :: jmonth, jday, tloc
- INTEGER :: IRIOPTION, USOIL, DSOIL
- REAL :: AOASIS, OMG
- REAL :: DRELR_URB
- REAL :: DRELB_URB
- REAL :: DRELG_URB
- REAL :: FLXHUMR_URB
- REAL :: FLXHUMB_URB
- REAL :: FLXHUMG_URB
- REAL :: CMCR_URB
- REAL :: TGR_URB
- REAL, DIMENSION(1:num_roof_layers) :: SMR_URB ! green roof layer moisture
- REAL, DIMENSION(1:num_roof_layers) :: TGRL_URB ! green roof layer temp [K]
-
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELR_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELB_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELG_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMR_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMB_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMG_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMCR_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TGR_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: TGRL_URB3D
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: SMR_URB3D
-
-! state variable surface_driver <--> lsm <--> urban
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TR_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TB_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TG_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TC_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: QC_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UC_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXR_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXB_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXG_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXC_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SH_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LH_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: G_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: RN_URB2D
-!
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TS_URB2D
-
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: TRL_URB3D
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_wall_layers, jms:jme ), INTENT(INOUT) :: TBL_URB3D
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_road_layers, jms:jme ), INTENT(INOUT) :: TGL_URB3D
-
-! output variable lsm --> surface_driver
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: PSIM_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: PSIH_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: GZ1OZ0_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: U10_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: V10_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: TH2_URB2D
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: Q2_URB2D
-!
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: AKMS_URB2D
-!
- REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: UST_URB2D
- REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FRC_URB2D ! change this to inout, danli mosaic
- INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: UTYPE_URB2D
-
-! output variables urban --> lsm
- REAL :: TS_URB ! surface radiative temperature [K]
- REAL :: QS_URB ! surface humidity [-]
- REAL :: SH_URB ! sensible heat flux [W/m/m]
- REAL :: LH_URB ! latent heat flux [W/m/m]
- REAL :: LH_KINEMATIC_URB ! latent heat flux, kinetic [kg/m/m/s]
- REAL :: SW_URB ! upward short wave radiation flux [W/m/m]
- REAL :: ALB_URB ! time-varying albedo [fraction]
- REAL :: LW_URB ! upward long wave radiation flux [W/m/m]
- REAL :: G_URB ! heat flux into the ground [W/m/m]
- REAL :: RN_URB ! net radiation [W/m/m]
- REAL :: PSIM_URB ! shear f for momentum [-]
- REAL :: PSIH_URB ! shear f for heat [-]
- REAL :: GZ1OZ0_URB ! shear f for heat [-]
- REAL :: U10_URB ! wind u component at 10 m [m/s]
- REAL :: V10_URB ! wind v component at 10 m [m/s]
- REAL :: TH2_URB ! potential temperature at 2 m [K]
- REAL :: Q2_URB ! humidity at 2 m [-]
- REAL :: CHS_URB
- REAL :: CHS2_URB
- REAL :: UST_URB
-! NUDAPT Parameters urban --> lam
- REAL :: mh_urb
- REAL :: stdh_urb
- REAL :: lp_urb
- REAL :: hgt_urb
- REAL, DIMENSION(4) :: lf_urb
-! Variables for multi-layer UCM (Martilli et al. 2002)
- REAL, OPTIONAL, INTENT(IN ) :: GMT
- INTEGER, OPTIONAL, INTENT(IN ) :: JULDAY
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) ::XLAT, XLONG
- INTEGER, INTENT(IN ) :: num_urban_ndm
- INTEGER, INTENT(IN ) :: urban_map_zrd
- INTEGER, INTENT(IN ) :: urban_map_zwd
- INTEGER, INTENT(IN ) :: urban_map_gd
- INTEGER, INTENT(IN ) :: urban_map_zd
- INTEGER, INTENT(IN ) :: urban_map_zdf
- INTEGER, INTENT(IN ) :: urban_map_bd
- INTEGER, INTENT(IN ) :: urban_map_wd
- INTEGER, INTENT(IN ) :: urban_map_gbd
- INTEGER, INTENT(IN ) :: urban_map_fbd
- INTEGER, INTENT(IN ) :: urban_map_zgrd
- INTEGER, INTENT(IN ) :: NUM_URBAN_HI
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: tsk_rural_bep
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zrd, jms:jme ), INTENT(INOUT) :: trb_urb4d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zwd, jms:jme ), INTENT(INOUT) :: tw1_urb4d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zwd, jms:jme ), INTENT(INOUT) :: tw2_urb4d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_gd , jms:jme ), INTENT(INOUT) :: tgb_urb4d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_bd , jms:jme ), INTENT(INOUT) :: tlev_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_bd , jms:jme ), INTENT(INOUT) :: qlev_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: tw1lev_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: tw2lev_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_gbd, jms:jme ), INTENT(INOUT) :: tglev_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_fbd, jms:jme ), INTENT(INOUT) :: tflev_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lf_ac_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sf_ac_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: cm_ac_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sfvent_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lfvent_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: sfwin1_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: sfwin2_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zd , jms:jme ), INTENT(INOUT) :: sfw1_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zd , jms:jme ), INTENT(INOUT) :: sfw2_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: sfr_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ), INTENT(INOUT) :: sfg_urb3d
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ep_pv_urb3d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: t_pv_urb3d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zgrd, jms:jme ),INTENT(INOUT) :: trv_urb4d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zgrd, jms:jme ),INTENT(INOUT) :: qr_urb4d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime,jms:jme ), INTENT(INOUT) :: qgr_urb3d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime,jms:jme ), INTENT(INOUT) :: tgr_urb3d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: drain_urb4d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: draingr_urb3d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: sfrv_urb3d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: lfrv_urb3d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: dgr_urb3d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ),INTENT(INOUT) :: dg_urb3d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: lfr_urb3d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ),INTENT(INOUT) :: lfg_urb3d !GRZ
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_hi, jms:jme ), INTENT(IN) :: hi_urb2d
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: lp_urb2d
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: lb_urb2d
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: hgt_urb2d
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: mh_urb2d
- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: stdh_urb2d
- REAL, OPTIONAL, DIMENSION( ims:ime, 4, jms:jme ), INTENT(IN) :: lf_urb2d
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_u_bep !Implicit momemtum component X-direction
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_v_bep !Implicit momemtum component Y-direction
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_t_bep !Implicit component pot. temperature
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_q_bep !Implicit momemtum component X-direction
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_e_bep !Implicit component TKE
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_u_bep !Explicit momentum component X-direction
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_v_bep !Explicit momentum component Y-direction
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_t_bep !Explicit component pot. temperature
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_q_bep !Implicit momemtum component Y-direction
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_e_bep !Explicit component TKE
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::vl_bep !Fraction air volume in grid cell
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::dlg_bep !Height above ground
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::sf_bep !Fraction air at the face of grid cell
- REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::dl_u_bep !Length scale
-
-! Local variables for multi-layer UCM (Martilli et al. 2002)
- REAL, DIMENSION( its:ite, jts:jte ) :: HFX_RURAL,LH_RURAL,GRDFLX_RURAL ! ,RN_RURAL
- REAL, DIMENSION( its:ite, jts:jte ) :: QFX_RURAL ! ,QSFC_RURAL,UMOM_RURAL,VMOM_RURAL
- REAL, DIMENSION( its:ite, jts:jte ) :: ALB_RURAL,EMISS_RURAL,TSK_RURAL ! ,UST_RURAL
-! REAL, DIMENSION( ims:ime, jms:jme ) :: QSFC_URB
- REAL, DIMENSION( its:ite, jts:jte ) :: HFX_URB,UMOM_URB,VMOM_URB
- REAL, DIMENSION( its:ite, jts:jte ) :: QFX_URB
-! REAL, DIMENSION( ims:ime, jms:jme ) :: ALBEDO_URB,EMISS_URB,UMOM,VMOM,UST
- REAL, DIMENSION(its:ite,jts:jte) ::EMISS_URB
- REAL, DIMENSION(its:ite,jts:jte) :: RL_UP_URB
- REAL, DIMENSION(its:ite,jts:jte) ::RS_ABS_URB
- REAL, DIMENSION(its:ite,jts:jte) ::GRDFLX_URB
- REAL :: SIGMA_SB,RL_UP_RURAL,RL_UP_TOT,RS_ABS_TOT,UMOM,VMOM
- REAL :: CMR_URB, CHR_URB, CMC_URB, CHC_URB, CMGR_URB, CHGR_URB
- REAL :: frc_urb,lb_urb
- REAL :: check
-! ----------------------------------------------------------------------
-! DECLARATIONS END - urban
-! ----------------------------------------------------------------------
-!-------------------------------------------------
-! Noah-mosaic related variables are added to declaration (danli)
-!-------------------------------------------------
-
- INTEGER, INTENT(IN) :: sf_surface_mosaic
- INTEGER, INTENT(IN) :: mosaic_cat, NLCAT
- REAL, DIMENSION( ims:ime, NLCAT, jms:jme ), INTENT(IN) :: landusef
- REAL, DIMENSION( ims:ime, NLCAT, jms:jme ), INTENT(INOUT) ::landusef2
- INTEGER, DIMENSION( ims:ime, NLCAT, jms:jme ), INTENT(INOUT) :: mosaic_cat_index
-
- REAL, DIMENSION( ims:ime, 1:mosaic_cat, jms:jme ) , OPTIONAL, INTENT(INOUT):: &
- TSK_mosaic, QSFC_mosaic, CANWAT_mosaic, SNOW_mosaic,SNOWH_mosaic, SNOWC_mosaic
- REAL, DIMENSION( ims:ime, 1:mosaic_cat, jms:jme ) , OPTIONAL, INTENT(INOUT):: &
- ALBEDO_mosaic,ALBBCK_mosaic, EMISS_mosaic, EMBCK_mosaic, ZNT_mosaic, Z0_mosaic, &
- HFX_mosaic,QFX_mosaic, LH_mosaic, GRDFLX_mosaic,SNOTIME_mosaic
- REAL, DIMENSION( ims:ime, 1:num_soil_layers*mosaic_cat, jms:jme ), OPTIONAL, INTENT(INOUT):: &
- TSLB_mosaic,SMOIS_mosaic,SH2O_mosaic
- REAL, DIMENSION( ims:ime, 1:mosaic_cat, jms:jme ), OPTIONAL, INTENT(INOUT):: LAI_mosaic, RC_mosaic
-
- REAL, DIMENSION( ims:ime, jms:jme ) :: TSK_mosaic_avg, QSFC_mosaic_avg, CANWAT_mosaic_avg,SNOW_mosaic_avg,SNOWH_mosaic_avg, &
- SNOWC_mosaic_avg, HFX_mosaic_avg, QFX_mosaic_avg, LH_mosaic_avg, GRDFLX_mosaic_avg, &
- ALBEDO_mosaic_avg, ALBBCK_mosaic_avg, EMISS_mosaic_avg, EMBCK_mosaic_avg, &
- ZNT_mosaic_avg, Z0_mosaic_avg, LAI_mosaic_avg, RC_mosaic_avg, SNOTIME_mosaic_avg, &
- FAREA_mosaic_avg
- REAL, DIMENSION( ims:ime, 1:num_soil_layers, jms:jme ) :: &
- TSLB_mosaic_avg,SMOIS_mosaic_avg,SH2O_mosaic_avg
-
- REAL, DIMENSION( ims:ime, 1:mosaic_cat, jms:jme ) , OPTIONAL, INTENT(INOUT):: &
- TR_URB2D_mosaic, TB_URB2D_mosaic, TG_URB2D_mosaic, TC_URB2D_mosaic,QC_URB2D_mosaic, UC_URB2D_mosaic, &
- SH_URB2D_mosaic,LH_URB2D_mosaic,G_URB2D_mosaic,RN_URB2D_mosaic,TS_URB2D_mosaic, TS_RUL2D_mosaic
-
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers*mosaic_cat, jms:jme ), INTENT(INOUT) :: TRL_URB3D_mosaic
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_wall_layers*mosaic_cat, jms:jme ), INTENT(INOUT) :: TBL_URB3D_mosaic
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_road_layers*mosaic_cat, jms:jme ), INTENT(INOUT) :: TGL_URB3D_mosaic
-
- INTEGER, DIMENSION( ims:ime, jms:jme ) :: IVGTYP_dominant
- INTEGER :: mosaic_i, URBAN_METHOD, zo_avg_option
- REAL :: FAREA
- LOGICAL :: IPRINT_mosaic, Noah_call
-!-------------------------------------------------
-! Noah-mosaic related variables declaration end (danli)
-!-------------------------------------------------
-
- REAL, PARAMETER :: CAPA=R_D/CP
- REAL :: APELM,APES,SFCTH2,PSFC
- real, intent(in) :: xice_threshold
- character(len=80) :: message_text
-!
-! FASDAS: it doesn't work for mosaic, but we need the variables to call sflx
-!
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(INOUT) :: SDA_HFX, SDA_QFX, HFX_BOTH, QFX_BOTH, QNORM
- INTEGER, INTENT(IN ) :: fasdas
- REAL :: XSDA_HFX, XSDA_QFX, XQNORM
- REAL :: HFX_PHY, QFX_PHY
- REAL :: DZQ
- REAL :: HCPCT_FASDAS
- REAL,OPTIONAL,DIMENSION( ims:ime, jms:jme ) :: IRR_CHAN
- REAL :: IRRIGATION_CHANNEL
- IRRIGATION_CHANNEL=0.0
- HFX_PHY = 0.0 ! initialize
- QFX_PHY = 0.0
- XQNORM = 0.0
- XSDA_HFX = 0.0
- XSDA_QFX = 0.0
-!
-! END FASDAS
-!
-! MEK MAY 2007
- FDTLIW=DT/ROWLIW
-! MEK JUL2007
- FDTW=DT/(XLV*RHOWATER)
-! debug printout
- IPRINT=.false.
- IPRINT_mosaic=.false.
-
-! SLOPETYP=2
- SLOPETYP=1
-! SHDMIN=0.00
-
- NSOIL=num_soil_layers
-
- DO NS=1,NSOIL
- SLDPTH(NS)=DZS(NS)
- ENDDO
-
- JLOOP : DO J=jts,jte
-
- IF(ITIMESTEP.EQ.1)THEN
- DO 50 I=its,ite
-!*** initialize soil conditions for IHOP 31 May case
-! IF((XLAND(I,J)-1.5) < 0.)THEN
-! if (I==108.and.j==85) then
-! DO NS=1,NSOIL
-! SMOIS(I,NS,J)=0.10
-! SH2O(I,NS,J)=0.10
-! enddo
-! endif
-! ENDIF
-
-!*** SET ZERO-VALUE FOR SOME OUTPUT DIAGNOSTIC ARRAYS
- IF((XLAND(I,J)-1.5).GE.0.)THEN
-! check sea-ice point
-#if 0
- IF( XICE(I,J).GE. XICE_THRESHOLD .and. IPRINT ) PRINT*, ' sea-ice at water point, I=',I,'J=',J
-#endif
-!*** Open Water Case
- SMSTAV(I,J)=1.0
- SMSTOT(I,J)=1.0
- DO NS=1,NSOIL
- SMOIS(I,NS,J)=1.0
- TSLB(I,NS,J)=273.16 !STEMP
- SMCREL(I,NS,J)=1.0
- ENDDO
- ELSE
- IF ( XICE(I,J) .GE. XICE_THRESHOLD ) THEN
-!*** SEA-ICE CASE
- SMSTAV(I,J)=1.0
- SMSTOT(I,J)=1.0
- DO NS=1,NSOIL
- SMOIS(I,NS,J)=1.0
- SMCREL(I,NS,J)=1.0
- ENDDO
- ENDIF
- ENDIF
-!
- 50 CONTINUE
- ENDIF ! end of initialization over ocean
-
-!-----------------------------------------------------------------------
- ILOOP : DO I=its,ite
-
- IF (((XLAND(I,J)-1.5).LT.0.) .AND. (XICE(I,J) < XICE_THRESHOLD) ) THEN
-
- IVGTYP_dominant(I,J)=IVGTYP(I,J) ! save this
-
- ! INITIALIZE THE AREA-AVERAGED FLUXES
-
- TSK_mosaic_avg(i,j)= 0.0 ! from 3D to 2D
- QSFC_mosaic_avg(i,j)= 0.0
- CANWAT_mosaic_avg(i,j)= 0.0
- SNOW_mosaic_avg(i,j)= 0.0
- SNOWH_mosaic_avg(i,j)= 0.0
- SNOWC_mosaic_avg(i,j)= 0.0
-
- DO NS=1,NSOIL
-
- TSLB_mosaic_avg(i,NS,j)=0.0
- SMOIS_mosaic_avg(i,NS,j)=0.0
- SH2O_mosaic_avg(i,NS,j)=0.0
-
- ENDDO
-
- HFX_mosaic_avg(i,j)= 0.0
- QFX_mosaic_avg(i,j)= 0.0
- LH_mosaic_avg(i,j)= 0.0
- GRDFLX_mosaic_avg(i,j)= 0.0
- ALBEDO_mosaic_avg(i,j)=0.0
- ALBBCK_mosaic_avg(i,j)=0.0
- EMISS_mosaic_avg(i,j)=0.0
- EMBCK_mosaic_avg(i,j)=0.0
- ZNT_mosaic_avg(i,j)=0.0
- Z0_mosaic_avg(i,j)=0.0
- LAI_mosaic_avg(i,j)=0.0
- RC_mosaic_avg(i,j)=0.0
- FAREA_mosaic_avg(i,j)=0.0
-
- ! add a new loop for the mosaic_cat
-
- DO mosaic_i = mosaic_cat, 1, -1
-
- ! if (mosaic_cat_index(I,mosaic_i,J) .EQ. 16 ) then
- ! PRINT*, 'you still have water tiles at','i=',i,'j=',j, 'mosaic_i',mosaic_i
- ! PRINT*, 'xland',xland(i,j),'xice',xice(i,j)
- ! endif
-
- IVGTYP(I,J)=mosaic_cat_index(I,mosaic_i,J) ! replace it with the mosaic one
- TSK(I,J)=TSK_mosaic(I,mosaic_i,J) ! from 3D to 2D
- QSFC(i,j)=QSFC_mosaic(I,mosaic_i,J)
- CANWAT(i,j)=CANWAT_mosaic(i,mosaic_i,j)
- SNOW(i,j)=SNOW_mosaic(i,mosaic_i,j)
- SNOWH(i,j)=SNOWH_mosaic(i,mosaic_i,j)
- SNOWC(i,j)=SNOWC_mosaic(i,mosaic_i,j)
-
- ALBEDO(i,j) = ALBEDO_mosaic(i,mosaic_i,j)
- ALBBCK(i,j)= ALBBCK_mosaic(i,mosaic_i,j)
- EMISS(i,j)= EMISS_mosaic(i,mosaic_i,j)
- EMBCK(i,j)= EMBCK_mosaic(i,mosaic_i,j)
- ZNT(i,j)= ZNT_mosaic(i,mosaic_i,j)
- Z0(i,j)= Z0_mosaic(i,mosaic_i,j)
-
- SNOTIME(i,j)= SNOTIME_mosaic(i,mosaic_i,j)
-
- DO NS=1,NSOIL
-
- TSLB(i,NS,j)=TSLB_mosaic(i,NSOIL*(mosaic_i-1)+NS,j)
- SMOIS(i,NS,j)=SMOIS_mosaic(i,NSOIL*(mosaic_i-1)+NS,j)
- SH2O(i,NS,j)=SH2O_mosaic(i,NSOIL*(mosaic_i-1)+NS,j)
-
- ENDDO
-
- IF(IPRINT_mosaic) THEN
-
- print*, 'BEFORE SFLX, in Noahdrv.F'
- print*, 'mosaic_cat', mosaic_cat, 'IVGTYP',IVGTYP(i,j), 'TSK',TSK(i,j),'HFX',HFX(i,j), 'QSFC', QSFC(i,j), &
- 'CANWAT', CANWAT(i,j), 'SNOW',SNOW(i,j), 'ALBEDO',ALBEDO(i,j), 'TSLB',TSLB(i,1,j),'CHS',CHS(i,j),'ZNT',ZNT(i,j)
-
- ENDIF
-
- !-----------------------------------------------------------------------
- ! insert the NOAH model here for the non-urban one and the urban one DANLI
- !-----------------------------------------------------------------------
-
- ! surface pressure
- PSFC=P8w3D(i,1,j)
- ! pressure in middle of lowest layer
- SFCPRS=(P8W3D(I,KTS+1,j)+P8W3D(i,KTS,j))*0.5
- ! convert from mixing ratio to specific humidity
- Q2K=QV3D(i,1,j)/(1.0+QV3D(i,1,j))
- !
- ! Q2SAT=QGH(I,j)
- Q2SAT=QGH(I,J)/(1.0+QGH(I,J)) ! Q2SAT is sp humidity
- ! add check on myj=.true.
- ! IF((Q2K.GE.Q2SAT*TRESH).AND.Q2K.LT.QZ0(I,J))THEN
- IF((myj).AND.(Q2K.GE.Q2SAT*TRESH).AND.Q2K.LT.QZ0(I,J))THEN
- SATFLG=0.
- CHKLOWQ(I,J)=0.
- ELSE
- SATFLG=1.0
- CHKLOWQ(I,J)=1.
- ENDIF
-
- SFCTMP=T3D(i,1,j)
- ZLVL=0.5*DZ8W(i,1,j)
-
- ! TH2=SFCTMP+(0.0097545*ZLVL)
- ! calculate SFCTH2 via Exner function vs lapse-rate (above)
- APES=(1.E5/PSFC)**CAPA
- APELM=(1.E5/SFCPRS)**CAPA
- SFCTH2=SFCTMP*APELM
- TH2=SFCTH2/APES
- !
- EMISSI = EMISS(I,J)
- LWDN=GLW(I,J)*EMISSI
- ! SOLDN is total incoming solar
- SOLDN=SWDOWN(I,J)
- ! GSW is net downward solar
- ! SOLNET=GSW(I,J)
- ! use mid-day albedo to determine net downward solar (no solar zenith angle correction)
- SOLNET=SOLDN*(1.-ALBEDO(I,J))
- PRCP=RAINBL(i,j)/DT
- IF(PRESENT(IRR_CHAN)) THEN
- IF(IRR_CHAN(i,j).NE.0) THEN
- IRRIGATION_CHANNEL=IRR_CHAN(i,j)/DT
- ELSE
- IRRIGATION_CHANNEL=0.
- END IF
- ENDIF
- VEGTYP=IVGTYP(I,J)
- SOILTYP=ISLTYP(I,J)
- SHDFAC=VEGFRA(I,J)/100.
- T1=TSK(I,J)
- CHK=CHS(I,J)
- SHMIN=SHDMIN(I,J)/100. !NEW
- SHMAX=SHDMAX(I,J)/100. !NEW
- ! convert snow water equivalent from mm to meter
- SNEQV=SNOW(I,J)*0.001
- ! snow depth in meters
- SNOWHK=SNOWH(I,J)
- SNCOVR=SNOWC(I,J)
-
- ! if "SR" present, set frac of frozen precip ("FFROZP") = snow-ratio ("SR", range:0-1)
- ! SR from e.g. Ferrier microphysics
- ! otherwise define from 1st atmos level temperature
- IF(FRPCPN) THEN
- FFROZP=SR(I,J)
- ELSE
- IF (SFCTMP <= 273.15) THEN
- FFROZP = 1.0
- ELSE
- FFROZP = 0.0
- ENDIF
- ENDIF
- !***
- IF((XLAND(I,J)-1.5).GE.0.)THEN ! begining of land/sea if block
- ! Open water points
- TSK_RURAL(I,J)=TSK(I,J)
- HFX_RURAL(I,J)=HFX(I,J)
- QFX_RURAL(I,J)=QFX(I,J)
- LH_RURAL(I,J)=LH(I,J)
- EMISS_RURAL(I,J)=EMISS(I,J)
- GRDFLX_RURAL(I,J)=GRDFLX(I,J)
- ELSE
- ! Land or sea-ice case
-
- IF (XICE(I,J) >= XICE_THRESHOLD) THEN
- ! Sea-ice point
- ICE = 1
- ELSE IF ( VEGTYP == ISICE ) THEN
- ! Land-ice point
- ICE = -1
- ELSE
- ! Neither sea ice or land ice.
- ICE=0
- ENDIF
- DQSDT2=Q2SAT*A23M4/(SFCTMP-A4)**2
-
- IF(SNOW(I,J).GT.0.0)THEN
- ! snow on surface (use ice saturation properties)
- SFCTSNO=SFCTMP
- E2SAT=611.2*EXP(6174.*(1./273.15 - 1./SFCTSNO))
- Q2SATI=0.622*E2SAT/(SFCPRS-E2SAT)
- Q2SATI=Q2SATI/(1.0+Q2SATI) ! spec. hum.
- IF (T1 .GT. 273.14) THEN
- ! warm ground temps, weight the saturation between ice and water according to SNOWC
- Q2SAT=Q2SAT*(1.-SNOWC(I,J)) + Q2SATI*SNOWC(I,J)
- DQSDT2=DQSDT2*(1.-SNOWC(I,J)) + Q2SATI*6174./(SFCTSNO**2)*SNOWC(I,J)
- ELSE
- ! cold ground temps, use ice saturation only
- Q2SAT=Q2SATI
- DQSDT2=Q2SATI*6174./(SFCTSNO**2)
- ENDIF
- ! for snow cover fraction at 0 C, ground temp will not change, so DQSDT2 effectively zero
- IF(T1 .GT. 273. .AND. SNOWC(I,J) .GT. 0.)DQSDT2=DQSDT2*(1.-SNOWC(I,J))
- ENDIF
-
- ! Land-ice or land points use the usual deep-soil temperature.
- TBOT=TMN(I,J)
-
- IF(VEGTYP.EQ.25) SHDFAC=0.0000
- IF(VEGTYP.EQ.26) SHDFAC=0.0000
- IF(VEGTYP.EQ.27) SHDFAC=0.0000
- IF(SOILTYP.EQ.14.AND.XICE(I,J).EQ.0.)THEN
-#if 0
- IF(IPRINT)PRINT*,' SOIL TYPE FOUND TO BE WATER AT A LAND-POINT'
- IF(IPRINT)PRINT*,i,j,'RESET SOIL in surfce.F'
-#endif
- SOILTYP=7
- ENDIF
- SNOALB1 = SNOALB(I,J)
-! converts canwat in mm to CMC in meters
- CMC=CANWAT(I,J)/1000.
-
- !-------------------------------------------
- !*** convert snow depth from mm to meter
- !
- ! IF(RDMAXALB) THEN
- ! SNOALB=ALBMAX(I,J)*0.01
- ! ELSE
- ! SNOALB=MAXALB(IVGTPK)*0.01
- ! ENDIF
-
- ! SNOALB1=0.80
- ! SHMIN=0.00
- ALBBRD=ALBBCK(I,J)
- Z0BRD=Z0(I,J)
- EMBRD=EMBCK(I,J)
- SNOTIME1 = SNOTIME(I,J)
- RIBB=RIB(I,J)
- !FEI: temporaray arrays above need to be changed later by using SI
-
- DO NS=1,NSOIL
- SMC(NS)=SMOIS(I,NS,J)
- STC(NS)=TSLB(I,NS,J) !STEMP
- SWC(NS)=SH2O(I,NS,J)
- ENDDO
- !
- if ( (SNEQV.ne.0..AND.SNOWHK.eq.0.).or.(SNOWHK.le.SNEQV) )THEN
- SNOWHK= 5.*SNEQV
- endif
- !
-
- !Fei: urban. for urban surface, if calling UCM, redefine the natural surface in cities as
- ! the "NATURAL" category in the VEGPARM.TBL
-
- ! IF(SF_URBAN_PHYSICS == 1.OR. SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN
-
-
- ! IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. &
- ! IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN
- ! VEGTYP = NATURAL
- ! SHDFAC = SHDTBL(NATURAL)
- ! ALBEDOK =0.2 ! 0.2
- ! ALBBRD =0.2 !0.2
- ! EMISSI = 0.98 !for VEGTYP=5
- ! IF ( FRC_URB2D(I,J) < 0.99 ) THEN
- ! if(sf_urban_physics.eq.1)then
- ! T1= ( TSK(I,J) -FRC_URB2D(I,J) * TS_URB2D (I,J) )/ (1-FRC_URB2D(I,J))
- ! elseif((sf_urban_physics.eq.2).OR.(sf_urban_physics.eq.3))then
- ! r1= (tsk(i,j)**4.)
- ! r2= frc_urb2d(i,j)*(ts_urb2d(i,j)**4.)
- ! r3= (1.-frc_urb2d(i,j))
- ! t1= ((r1-r2)/r3)**.25
- ! endif
- ! ELSE
- ! T1 = TSK(I,J)
- ! ENDIF
- ! ENDIF
- ! ELSE
- ! IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. &
- ! IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN
- ! VEGTYP = ISURBAN
- ! ENDIF
- ! ENDIF
-
- Noah_call=.TRUE.
-
- If ( SF_URBAN_PHYSICS == 0 ) THEN ! ONLY NOAH
- IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. &
- IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. &
- IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. &
- IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN
-
- Noah_call = .TRUE.
- VEGTYP = ISURBAN
- ENDIF
-
- ENDIF
-
- IF(SF_URBAN_PHYSICS == 1) THEN
-
- IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. &
- IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. &
- IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. &
- IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN
- Noah_call = .TRUE.
- VEGTYP = NATURAL
- SHDFAC = SHDTBL(NATURAL)
- ALBEDOK =0.2 ! 0.2
- ALBBRD =0.2 ! 0.2
- EMISSI = 0.98 ! for VEGTYP=5
-
- T1= TS_RUL2D_mosaic(I,mosaic_i,J)
-
- ENDIF
-
- ENDIF
-
-!===Yang, 2014/10/08, hydrological processes for urban vegetation in single layer UCM===
- AOASIS = 1.0
- USOIL = 1
- DSOIL = 2
- IRIOPTION=IRI_SCHEME
- OMG= OMG_URB2D(I,J)
- tloc=mod(int(OMG/3.14159*180./15.+12.+0.5 ),24)
- if (tloc.lt.0) tloc=tloc+24
- if (tloc==0) tloc=24
- CALL cal_mon_day(julian,julyr,jmonth,jday)
- IF(SF_URBAN_PHYSICS == 1) THEN
- IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. &
- IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. &
- IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. &
- IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN
-
- AOASIS = oasis ! urban oasis effect
- IF (IRIOPTION ==1) THEN
- IF (tloc==21 .or. tloc==22) THEN !irrigation on vegetaion in urban area, MAY-SEP, 9-10pm
- IF (jmonth==5 .or. jmonth==6 .or. jmonth==7 .or. jmonth==8 .or. jmonth==9) THEN
- IF (SMC(USOIL) .LT. SMCREF) SMC(USOIL)= REFSMC(ISLTYP(I,J))
- IF (SMC(DSOIL) .LT. SMCREF) SMC(DSOIL)= REFSMC(ISLTYP(I,J))
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- ENDIF
-
- IF(SF_URBAN_PHYSICS == 2 .or. SF_URBAN_PHYSICS == 3) THEN
- IF(AOASIS > 1.0) THEN
- CALL wrf_error_fatal('Urban oasis option is for SF_URBAN_PHYSICS == 1 only')
- ENDIF
- IF(IRIOPTION == 1) THEN
- CALL wrf_error_fatal('Urban irrigation option is for SF_URBAN_PHYSICS == 1 only')
- ENDIF
- ENDIF
-
- IF( SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN
-! print*, 'MOSAIC is not designed to work with SF_URBAN_PHYSICS=2 or SF_URBAN_PHYSICS=3'
- ENDIF
-
- IF (Noah_call) THEN
-#if 0
- IF(IPRINT) THEN
- !
- print*, 'BEFORE SFLX, in Noahlsm_driver'
- print*, 'ICE', ICE, 'DT',DT, 'ZLVL',ZLVL, 'NSOIL', NSOIL, &
- 'SLDPTH', SLDPTH, 'LOCAL',LOCAL, 'LUTYPE',&
- LUTYPE, 'SLTYPE',SLTYPE, 'LWDN',LWDN, 'SOLDN',SOLDN, &
- 'SFCPRS',SFCPRS, 'PRCP',PRCP,'SFCTMP',SFCTMP,'Q2K',Q2K, &
- 'TH2',TH2,'Q2SAT',Q2SAT,'DQSDT2',DQSDT2,'VEGTYP', VEGTYP,&
- 'SOILTYP',SOILTYP, 'SLOPETYP',SLOPETYP, 'SHDFAC',SHDFAC,&
- 'SHMIN',SHMIN, 'ALBBRD',ALBBRD,'SNOALB1',SNOALB1,'TBOT',&
- TBOT, 'Z0BRD',Z0BRD, 'Z0K',Z0K, 'CMC',CMC, 'T1',T1,'STC',&
- STC, 'SMC',SMC, 'SWC',SWC,'SNOWHK',SNOWHK,'SNEQV',SNEQV,&
- 'ALBEDOK',ALBEDOK,'CHK',CHK,'ETA',ETA,'SHEAT',SHEAT, &
- 'ETA_KINEMATIC',ETA_KINEMATIC, 'FDOWN',FDOWN,'EC',EC, &
- 'EDIR',EDIR,'ET',ET,'ETT',ETT,'ESNOW',ESNOW,'DRIP',DRIP,&
- 'DEW',DEW,'BETA',BETA,'ETP',ETP,'SSOIL',SSOIL,'FLX1',FLX1,&
- 'FLX2',FLX2,'FLX3',FLX3,'SNOMLT',SNOMLT,'SNCOVR',SNCOVR,&
- 'RUNOFF1',RUNOFF1,'RUNOFF2',RUNOFF2,'RUNOFF3',RUNOFF3, &
- 'RC',RC, 'PC',PC,'RSMIN',RSMIN,'XLAI',XLAI,'RCS',RCS, &
- 'RCT',RCT,'RCQ',RCQ,'RCSOIL',RCSOIL,'SOILW',SOILW, &
- 'SOILM',SOILM,'Q1',Q1,'SMCWLT',SMCWLT,'SMCDRY',SMCDRY,&
- 'SMCREF',SMCREF,'SMCMAX',SMCMAX,'NROOT',NROOT
- endif
-#endif
-
- IF (rdlai2d) THEN
- IF (SHDFAC > 0.0 .AND. LAI(I,J) <= 0.0) LAI(I,J) = 0.01
- xlai = lai(i,j)
- endif
-
- IF ( ICE == 1 ) THEN
-
- ! Sea-ice case
-
- DO NS = 1, NSOIL
- SH2O(I,NS,J) = 1.0
- ENDDO
- LAI(I,J) = 0.01
-
- CYCLE ILOOP
-
- ELSEIF (ICE == 0) THEN
-
- ! Non-glacial land
-
- CALL SFLX (I,J,FFROZP, ISURBAN, DT,ZLVL,NSOIL,SLDPTH, & !C
- LOCAL, & !L
- LUTYPE, SLTYPE, & !CL
- LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K,DUMMY, & !F
- DUMMY,DUMMY, DUMMY, & !F PRCPRAIN not used
- TH2,Q2SAT,DQSDT2, & !I
- VEGTYP,SOILTYP,SLOPETYP,SHDFAC,SHMIN,SHMAX, & !I
- ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, & !S
- CMC,T1,STC,SMC,SWC,SNOWHK,SNEQV,ALBEDOK,CHK,dummy,& !H
- ETA,SHEAT, ETA_KINEMATIC,FDOWN, & !O
- EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, & !O
- BETA,ETP,SSOIL, & !O
- FLX1,FLX2,FLX3, & !O
- FLX4,FVB,FBUR,FGSN,UA_PHYS, & !UA
- SNOMLT,SNCOVR, & !O
- RUNOFF1,RUNOFF2,RUNOFF3, & !O
- RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, & !O
- SOILW,SOILM,Q1,SMAV, & !D
- RDLAI2D,USEMONALB, &
- SNOTIME1, &
- RIBB, &
- SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT, &
- sfcheadrt(i,j), & !I
- INFXSRT(i,j),ETPND1,OPT_THCND,AOASIS & !O
- ,XSDA_QFX, HFX_PHY, QFX_PHY, XQNORM, fasdas, HCPCT_FASDAS & ! fasdas vars
- ,IRRIGATION_CHANNEL )
-
-#ifdef WRF_HYDRO
- soldrain(i,j) = RUNOFF2*DT*1000.0
-#endif
- ELSEIF (ICE == -1) THEN
-
- !
- ! Set values that the LSM is expected to update,
- ! but don't get updated for glacial points.
- !
- SOILM = 0.0 !BSINGH(PNNL)- SOILM is undefined for this case, it is used for diagnostics so setting it to zero
- XLAI = 0.01 ! KWM Should this be Zero over land ice? Does this value matter?
- RUNOFF2 = 0.0
- RUNOFF3 = 0.0
- DO NS = 1, NSOIL
- SWC(NS) = 1.0
- SMC(NS) = 1.0
- SMAV(NS) = 1.0
- ENDDO
- CALL SFLX_GLACIAL(I,J,ISICE,FFROZP,DT,ZLVL,NSOIL,SLDPTH, & !C
- & LWDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K, & !F
- & TH2,Q2SAT,DQSDT2, & !I
- & ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, & !S
- & T1,STC(1:NSOIL),SNOWHK,SNEQV,ALBEDOK,CHK, & !H
- & ETA,SHEAT,ETA_KINEMATIC,FDOWN, & !O
- & ESNOW,DEW, & !O
- & ETP,SSOIL, & !O
- & FLX1,FLX2,FLX3, & !O
- & SNOMLT,SNCOVR, & !O
- & RUNOFF1, & !O
- & Q1, & !D
- & SNOTIME1, &
- & RIBB)
-
- ENDIF
- lai(i,j) = xlai
-#if 0
- IF(IPRINT) THEN
-
- print*, 'AFTER SFLX, in Noahlsm_driver'
- print*, 'ICE', ICE, 'DT',DT, 'ZLVL',ZLVL, 'NSOIL', NSOIL, &
- 'SLDPTH', SLDPTH, 'LOCAL',LOCAL, 'LUTYPE',&
- LUTYPE, 'SLTYPE',SLTYPE, 'LWDN',LWDN, 'SOLDN',SOLDN, &
- 'SFCPRS',SFCPRS, 'PRCP',PRCP,'SFCTMP',SFCTMP,'Q2K',Q2K, &
- 'TH2',TH2,'Q2SAT',Q2SAT,'DQSDT2',DQSDT2,'VEGTYP', VEGTYP,&
- 'SOILTYP',SOILTYP, 'SLOPETYP',SLOPETYP, 'SHDFAC',SHDFAC,&
- 'SHDMIN',SHMIN, 'ALBBRD',ALBBRD,'SNOALB',SNOALB1,'TBOT',&
- TBOT, 'Z0BRD',Z0BRD, 'Z0K',Z0K, 'CMC',CMC, 'T1',T1,'STC',&
- STC, 'SMC',SMC, 'SWc',SWC,'SNOWHK',SNOWHK,'SNEQV',SNEQV,&
- 'ALBEDOK',ALBEDOK,'CHK',CHK,'ETA',ETA,'SHEAT',SHEAT, &
- 'ETA_KINEMATIC',ETA_KINEMATIC, 'FDOWN',FDOWN,'EC',EC, &
- 'EDIR',EDIR,'ET',ET,'ETT',ETT,'ESNOW',ESNOW,'DRIP',DRIP,&
- 'DEW',DEW,'BETA',BETA,'ETP',ETP,'SSOIL',SSOIL,'FLX1',FLX1,&
- 'FLX2',FLX2,'FLX3',FLX3,'SNOMLT',SNOMLT,'SNCOVR',SNCOVR,&
- 'RUNOFF1',RUNOFF1,'RUNOFF2',RUNOFF2,'RUNOFF3',RUNOFF3, &
- 'RC',RC, 'PC',PC,'RSMIN',RSMIN,'XLAI',XLAI,'RCS',RCS, &
- 'RCT',RCT,'RCQ',RCQ,'RCSOIL',RCSOIL,'SOILW',SOILW, &
- 'SOILM',SOILM,'Q1',Q1,'SMCWLT',SMCWLT,'SMCDRY',SMCDRY,&
- 'SMCREF',SMCREF,'SMCMAX',SMCMAX,'NROOT',NROOT
- endif
-#endif
-
- !*** UPDATE STATE VARIABLES
- CANWAT(I,J)=CMC*1000.
- SNOW(I,J)=SNEQV*1000.
- ! SNOWH(I,J)=SNOWHK*1000.
- SNOWH(I,J)=SNOWHK ! SNOWHK in meters
- ALBEDO(I,J)=ALBEDOK
- ALB_RURAL(I,J)=ALBEDOK
- ALBBCK(I,J)=ALBBRD
- Z0(I,J)=Z0BRD
- EMISS(I,J) = EMISSI
- EMISS_RURAL(I,J) = EMISSI
- ! Noah: activate time-varying roughness length (V3.3 Feb 2011)
- ZNT(I,J)=Z0K
- TSK(I,J)=T1
- TSK_RURAL(I,J)=T1
- HFX(I,J)=SHEAT
- HFX_RURAL(I,J)=SHEAT
- ! MEk Jul07 add potential evap accum
- POTEVP(I,J)=POTEVP(I,J)+ETP*FDTW
- QFX(I,J)=ETA_KINEMATIC
- QFX_RURAL(I,J)=ETA_KINEMATIC
-
-#ifdef WRF_HYDRO
- !added by Wei Yu
- ! QFX(I,J) = QFX(I,J) + ETPND1
- ! ETA = ETA + ETPND1/2.501E6*dt
- !end added by Wei Yu
-#endif
-
- LH(I,J)=ETA
- LH_RURAL(I,J)=ETA
- GRDFLX(I,J)=SSOIL
- GRDFLX_RURAL(I,J)=SSOIL
- SNOWC(I,J)=SNCOVR
- CHS2(I,J)=CQS2(I,J)
- SNOTIME(I,J) = SNOTIME1
- ! prevent diagnostic ground q (q1) from being greater than qsat(tsk)
- ! as happens over snow cover where the cqs2 value also becomes irrelevant
- ! by setting cqs2=chs in this situation the 2m q should become just qv(k=1)
- IF (Q1 .GT. QSFC(I,J)) THEN
- CQS2(I,J) = CHS(I,J)
- ENDIF
- ! QSFC(I,J)=Q1
- ! Convert QSFC back to mixing ratio
- QSFC(I,J)= Q1/(1.0-Q1)
- !
- ! QSFC_RURAL(I,J)= Q1/(1.0-Q1)
- ! Calculate momentum flux from rural surface for use with multi-layer UCM (Martilli et al. 2002)
-
- DO 81 NS=1,NSOIL
- SMOIS(I,NS,J)=SMC(NS)
- TSLB(I,NS,J)=STC(NS) ! STEMP
- SH2O(I,NS,J)=SWC(NS)
- 81 CONTINUE
- ! ENDIF
-
- FLX4_2D(I,J) = FLX4
- FVB_2D(I,J) = FVB
- FBUR_2D(I,J) = FBUR
- FGSN_2D(I,J) = FGSN
-
- !
- ! Residual of surface energy balance equation terms
- !
-
- IF ( UA_PHYS ) THEN
- noahres(i,j) = ( solnet + lwdn ) - sheat + ssoil - eta &
- - ( emissi * STBOLT * (t1**4) ) - flx1 - flx2 - flx3 - flx4
-
- ELSE
- noahres(i,j) = ( solnet + lwdn ) - sheat + ssoil - eta &
- - ( emissi * STBOLT * (t1**4) ) - flx1 - flx2 - flx3
- ENDIF
-
- ENDIF !ENDIF FOR Noah_call
-
- IF (SF_URBAN_PHYSICS == 1 ) THEN ! Beginning of UCM CALL if block
- !--------------------------------------
- ! URBAN CANOPY MODEL START - urban
- !--------------------------------------
- ! Input variables lsm --> urban
- IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. &
- IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. &
- IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. &
- IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN
-
-
- ! UTYPE_URB = UTYPE_URB2D(I,J) !urban type (low, high or industrial)
- ! this need to be changed in the mosaic danli
- IF(IVGTYP(I,J)==ISURBAN) UTYPE_URB=5
- IF(IVGTYP(I,J)==LCZ_1) UTYPE_URB=1
- IF(IVGTYP(I,J)==LCZ_2) UTYPE_URB=2
- IF(IVGTYP(I,J)==LCZ_3) UTYPE_URB=3
- IF(IVGTYP(I,J)==LCZ_4) UTYPE_URB=4
- IF(IVGTYP(I,J)==LCZ_5) UTYPE_URB=5
- IF(IVGTYP(I,J)==LCZ_6) UTYPE_URB=6
- IF(IVGTYP(I,J)==LCZ_7) UTYPE_URB=7
- IF(IVGTYP(I,J)==LCZ_8) UTYPE_URB=8
- IF(IVGTYP(I,J)==LCZ_9) UTYPE_URB=9
- IF(IVGTYP(I,J)==LCZ_10) UTYPE_URB=10
- IF(IVGTYP(I,J)==LCZ_11) UTYPE_URB=11
-
-
- IF(UTYPE_URB==1) FRC_URB2D(I,J)=1.
- IF(UTYPE_URB==2) FRC_URB2D(I,J)=0.99
- IF(UTYPE_URB==3) FRC_URB2D(I,J)=1.00
- IF(UTYPE_URB==4) FRC_URB2D(I,J)=0.65
- IF(UTYPE_URB==5) FRC_URB2D(I,J)=0.7
- IF(UTYPE_URB==6) FRC_URB2D(I,J)=0.65
- IF(UTYPE_URB==7) FRC_URB2D(I,J)=0.3
- IF(UTYPE_URB==8) FRC_URB2D(I,J)=0.85
- IF(UTYPE_URB==9) FRC_URB2D(I,J)=0.3
- IF(UTYPE_URB==10) FRC_URB2D(I,J)=0.55
- IF(UTYPE_URB==11) FRC_URB2D(I,J)=1.
-
- TA_URB = SFCTMP ! [K]
- QA_URB = Q2K ! [kg/kg]
- UA_URB = SQRT(U_PHY(I,1,J)**2.+V_PHY(I,1,J)**2.)
- U1_URB = U_PHY(I,1,J)
- V1_URB = V_PHY(I,1,J)
- IF(UA_URB < 1.) UA_URB=1. ! [m/s]
- SSG_URB = SOLDN ! [W/m/m]
- SSGD_URB = 0.8*SOLDN ! [W/m/m]
- SSGQ_URB = SSG_URB-SSGD_URB ! [W/m/m]
- LLG_URB = GLW(I,J) ! [W/m/m]
- RAIN_URB = RAINBL(I,J) ! [mm]
- RHOO_URB = SFCPRS / (287.04 * SFCTMP * (1.0+ 0.61 * Q2K)) ![kg/m/m/m]
- ZA_URB = ZLVL ! [m]
- DELT_URB = DT ! [sec]
- XLAT_URB = XLAT_URB2D(I,J) ! [deg]
- COSZ_URB = COSZ_URB2D(I,J) !
- OMG_URB = OMG_URB2D(I,J) !
- ZNT_URB = ZNT(I,J)
-
- LSOLAR_URB = .FALSE.
-
- ! mosaic 3D to 2D
-
- TR_URB2D(I,J)=TR_URB2D_mosaic(I,mosaic_i,J) ! replace it with the mosaic one
- TB_URB2D(I,J)=TB_URB2D_mosaic(I,mosaic_i,J) ! replace it with the mosaic one
- TG_URB2D(I,J)=TG_URB2D_mosaic(I,mosaic_i,J) ! replace it with the mosaic one
- TC_URB2D(I,J)=TC_URB2D_mosaic(I,mosaic_i,J) ! replace it with the mosaic one
- QC_URB2D(I,J)=QC_URB2D_mosaic(I,mosaic_i,J) ! replace it with the mosaic one
- UC_URB2D(I,J)=UC_URB2D_mosaic(I,mosaic_i,J) ! replace it with the mosaic one
- TS_URB2D(I,J)=TS_URB2D_mosaic(I,mosaic_i,J) ! replace it with the mosaic one
-
- DO K = 1,num_roof_layers
- TRL_URB3D(I,K,J) = TRL_URB3D_mosaic(I,K+(mosaic_i-1)*num_roof_layers,J)
- END DO
- DO K = 1,num_wall_layers
- TBL_URB3D(I,K,J) = TBL_URB3D_mosaic(I,K+(mosaic_i-1)*num_roof_layers,J)
- END DO
- DO K = 1,num_road_layers
- TGL_URB3D(I,K,J) = TGL_URB3D_mosaic(I,K+(mosaic_i-1)*num_roof_layers,J)
- END DO
-
- ! mosaic 2D to 1D
-
- TR_URB = TR_URB2D(I,J)
- TB_URB = TB_URB2D(I,J)
- TG_URB = TG_URB2D(I,J)
- TC_URB = TC_URB2D(I,J)
- QC_URB = QC_URB2D(I,J)
- UC_URB = UC_URB2D(I,J)
-
- DO K = 1,num_roof_layers
- TRL_URB(K) = TRL_URB3D(I,K,J)
- SMR_URB(K) = SMR_URB3D(I,K,J)
- TGRL_URB(K)= TGRL_URB3D(I,K,J)
- END DO
- DO K = 1,num_wall_layers
- TBL_URB(K) = TBL_URB3D(I,K,J)
- END DO
- DO K = 1,num_road_layers
- TGL_URB(K) = TGL_URB3D(I,K,J)
- END DO
-
- TGR_URB = TGR_URB2D(I,J)
- CMCR_URB = CMCR_URB2D(I,J)
- FLXHUMR_URB = FLXHUMR_URB2D(I,J)
- FLXHUMB_URB = FLXHUMB_URB2D(I,J)
- FLXHUMG_URB = FLXHUMG_URB2D(I,J)
- DRELR_URB = DRELR_URB2D(I,J)
- DRELB_URB = DRELB_URB2D(I,J)
- DRELG_URB = DRELG_URB2D(I,J)
-
- XXXR_URB = XXXR_URB2D(I,J)
- XXXB_URB = XXXB_URB2D(I,J)
- XXXG_URB = XXXG_URB2D(I,J)
- XXXC_URB = XXXC_URB2D(I,J)
- !
- ! Limits to avoid dividing by small number
- if (CHS(I,J) < 1.0E-02) then
- CHS(I,J) = 1.0E-02
- endif
- if (CHS2(I,J) < 1.0E-02) then
- CHS2(I,J) = 1.0E-02
- endif
- if (CQS2(I,J) < 1.0E-02) then
- CQS2(I,J) = 1.0E-02
- endif
- !
- CHS_URB = CHS(I,J)
- CHS2_URB = CHS2(I,J)
- IF (PRESENT(CMR_SFCDIF)) THEN
- CMR_URB = CMR_SFCDIF(I,J)
- CHR_URB = CHR_SFCDIF(I,J)
- CMGR_URB = CMGR_SFCDIF(I,J)
- CHGR_URB = CHGR_SFCDIF(I,J)
- CMC_URB = CMC_SFCDIF(I,J)
- CHC_URB = CHC_SFCDIF(I,J)
- ENDIF
-
- ! NUDAPT for SLUCM
- mh_urb = mh_urb2d(I,J)
- stdh_urb = stdh_urb2d(I,J)
- lp_urb = lp_urb2d(I,J)
- hgt_urb = hgt_urb2d(I,J)
- lf_urb = 0.0
- DO K = 1,4
- lf_urb(K)=lf_urb2d(I,K,J)
- ENDDO
- frc_urb = frc_urb2d(I,J)
- lb_urb = lb_urb2d(I,J)
- check = 0
- if (I.eq.73.and.J.eq.125)THEN
- check = 1
- end if
- !
- ! Call urban
- CALL cal_mon_day(julian,julyr,jmonth,jday)
- CALL urban(LSOLAR_URB, & ! I
- num_roof_layers,num_wall_layers,num_road_layers, & ! C
- DZR,DZB,DZG, & ! C
- UTYPE_URB,TA_URB,QA_URB,UA_URB,U1_URB,V1_URB,SSG_URB, & ! I
- SSGD_URB,SSGQ_URB,LLG_URB,RAIN_URB,RHOO_URB, & ! I
- ZA_URB,DECLIN_URB,COSZ_URB,OMG_URB, & ! I
- XLAT_URB,DELT_URB,ZNT_URB, & ! I
- CHS_URB, CHS2_URB, & ! I
- TR_URB, TB_URB, TG_URB, TC_URB, QC_URB,UC_URB, & ! H
- TRL_URB,TBL_URB,TGL_URB, & ! H
- XXXR_URB, XXXB_URB, XXXG_URB, XXXC_URB, & ! H
- TS_URB,QS_URB,SH_URB,LH_URB,LH_KINEMATIC_URB, & ! O
- SW_URB,ALB_URB,LW_URB,G_URB,RN_URB,PSIM_URB,PSIH_URB, & ! O
- GZ1OZ0_URB, & !O
- CMR_URB, CHR_URB, CMC_URB, CHC_URB, &
- U10_URB, V10_URB, TH2_URB, Q2_URB, & ! O
- UST_URB,mh_urb, stdh_urb, lf_urb, lp_urb, & ! 0
- hgt_urb,frc_urb,lb_urb, check,CMCR_URB,TGR_URB, & ! H
- TGRL_URB,SMR_URB,CMGR_URB,CHGR_URB,jmonth, & ! H
- DRELR_URB,DRELB_URB, & ! H
- DRELG_URB,FLXHUMR_URB,FLXHUMB_URB,FLXHUMG_URB)
-
-#if 0
- IF(IPRINT) THEN
-
- print*, 'AFTER CALL URBAN'
- print*,'num_roof_layers',num_roof_layers, 'num_wall_layers', &
- num_wall_layers, &
- 'DZR',DZR,'DZB',DZB,'DZG',DZG,'UTYPE_URB',UTYPE_URB,'TA_URB', &
- TA_URB, &
- 'QA_URB',QA_URB,'UA_URB',UA_URB,'U1_URB',U1_URB,'V1_URB', &
- V1_URB, &
- 'SSG_URB',SSG_URB,'SSGD_URB',SSGD_URB,'SSGQ_URB',SSGQ_URB, &
- 'LLG_URB',LLG_URB,'RAIN_URB',RAIN_URB,'RHOO_URB',RHOO_URB, &
- 'ZA_URB',ZA_URB, 'DECLIN_URB',DECLIN_URB,'COSZ_URB',COSZ_URB,&
- 'OMG_URB',OMG_URB,'XLAT_URB',XLAT_URB,'DELT_URB',DELT_URB, &
- 'ZNT_URB',ZNT_URB,'TR_URB',TR_URB, 'TB_URB',TB_URB,'TG_URB',&
- TG_URB,'TC_URB',TC_URB,'QC_URB',QC_URB,'TRL_URB',TRL_URB, &
- 'TBL_URB',TBL_URB,'TGL_URB',TGL_URB,'XXXR_URB',XXXR_URB, &
- 'XXXB_URB',XXXB_URB,'XXXG_URB',XXXG_URB,'XXXC_URB',XXXC_URB,&
- 'TS_URB',TS_URB,'QS_URB',QS_URB,'SH_URB',SH_URB,'LH_URB', &
- LH_URB, 'LH_KINEMATIC_URB',LH_KINEMATIC_URB,'SW_URB',SW_URB,&
- 'ALB_URB',ALB_URB,'LW_URB',LW_URB,'G_URB',G_URB,'RN_URB', &
- RN_URB, 'PSIM_URB',PSIM_URB,'PSIH_URB',PSIH_URB, &
- 'U10_URB',U10_URB,'V10_URB',V10_URB,'TH2_URB',TH2_URB, &
- 'Q2_URB',Q2_URB,'CHS_URB',CHS_URB,'CHS2_URB',CHS2_URB
- endif
-#endif
-
- TS_URB2D(I,J) = TS_URB
-
- ALBEDO(I,J) = FRC_URB2D(I,J)*ALB_URB+(1-FRC_URB2D(I,J))*ALBEDOK ![-]
- HFX(I,J) = FRC_URB2D(I,J)*SH_URB+(1-FRC_URB2D(I,J))*SHEAT ![W/m/m]
- QFX(I,J) = FRC_URB2D(I,J)*LH_KINEMATIC_URB &
- + (1-FRC_URB2D(I,J))*ETA_KINEMATIC ![kg/m/m/s]
- LH(I,J) = FRC_URB2D(I,J)*LH_URB+(1-FRC_URB2D(I,J))*ETA ![W/m/m]
- GRDFLX(I,J) = FRC_URB2D(I,J)*G_URB+(1-FRC_URB2D(I,J))*SSOIL ![W/m/m]
- TSK(I,J) = FRC_URB2D(I,J)*TS_URB+(1-FRC_URB2D(I,J))*T1 ![K]
- Q1 = FRC_URB2D(I,J)*QS_URB+(1-FRC_URB2D(I,J))*Q1 ![-]
- ! Convert QSFC back to mixing ratio
- QSFC(I,J)= Q1/(1.0-Q1)
- UST(I,J)= FRC_URB2D(I,J)*UST_URB+(1-FRC_URB2D(I,J))*UST(I,J) ![m/s]
- ZNT(I,J)= EXP(FRC_URB2D(I,J)*ALOG(ZNT_URB)+(1-FRC_URB2D(I,J))* ALOG(ZNT(I,J))) ! ADD BY DAN
-
-#if 0
- IF(IPRINT)THEN
-
- print*, ' FRC_URB2D', FRC_URB2D, &
- 'ALB_URB',ALB_URB, 'ALBEDOK',ALBEDOK, &
- 'ALBEDO(I,J)', ALBEDO(I,J), &
- 'SH_URB',SH_URB,'SHEAT',SHEAT, 'HFX(I,J)',HFX(I,J), &
- 'LH_KINEMATIC_URB',LH_KINEMATIC_URB,'ETA_KINEMATIC', &
- ETA_KINEMATIC, 'QFX(I,J)',QFX(I,J), &
- 'LH_URB',LH_URB, 'ETA',ETA, 'LH(I,J)',LH(I,J), &
- 'G_URB',G_URB,'SSOIL',SSOIL,'GRDFLX(I,J)', GRDFLX(I,J),&
- 'TS_URB',TS_URB,'T1',T1,'TSK(I,J)',TSK(I,J), &
- 'QS_URB',QS_URB,'Q1',Q1,'QSFC(I,J)',QSFC(I,J)
- endif
-#endif
-
- ! Renew Urban State Varialbes
-
- TR_URB2D(I,J) = TR_URB
- TB_URB2D(I,J) = TB_URB
- TG_URB2D(I,J) = TG_URB
- TC_URB2D(I,J) = TC_URB
- QC_URB2D(I,J) = QC_URB
- UC_URB2D(I,J) = UC_URB
-
- DO K = 1,num_roof_layers
- TRL_URB3D(I,K,J) = TRL_URB(K)
- SMR_URB3D(I,K,J) = SMR_URB(K)
- TGRL_URB3D(I,K,J)= TGRL_URB(K)
- END DO
- DO K = 1,num_wall_layers
- TBL_URB3D(I,K,J) = TBL_URB(K)
- END DO
- DO K = 1,num_road_layers
- TGL_URB3D(I,K,J) = TGL_URB(K)
- END DO
-
- TGR_URB2D(I,J) =TGR_URB
- CMCR_URB2D(I,J)=CMCR_URB
- FLXHUMR_URB2D(I,J)=FLXHUMR_URB
- FLXHUMB_URB2D(I,J)=FLXHUMB_URB
- FLXHUMG_URB2D(I,J)=FLXHUMG_URB
- DRELR_URB2D(I,J) = DRELR_URB
- DRELB_URB2D(I,J) = DRELB_URB
- DRELG_URB2D(I,J) = DRELG_URB
-
- XXXR_URB2D(I,J) = XXXR_URB
- XXXB_URB2D(I,J) = XXXB_URB
- XXXG_URB2D(I,J) = XXXG_URB
- XXXC_URB2D(I,J) = XXXC_URB
-
- SH_URB2D(I,J) = SH_URB
- LH_URB2D(I,J) = LH_URB
- G_URB2D(I,J) = G_URB
- RN_URB2D(I,J) = RN_URB
- PSIM_URB2D(I,J) = PSIM_URB
- PSIH_URB2D(I,J) = PSIH_URB
- GZ1OZ0_URB2D(I,J)= GZ1OZ0_URB
- U10_URB2D(I,J) = U10_URB
- V10_URB2D(I,J) = V10_URB
- TH2_URB2D(I,J) = TH2_URB
- Q2_URB2D(I,J) = Q2_URB
- UST_URB2D(I,J) = UST_URB
- AKMS_URB2D(I,J) = KARMAN * UST_URB2D(I,J)/(GZ1OZ0_URB2D(I,J)-PSIM_URB2D(I,J))
- IF (PRESENT(CMR_SFCDIF)) THEN
- CMR_SFCDIF(I,J) = CMR_URB
- CHR_SFCDIF(I,J) = CHR_URB
- CMGR_SFCDIF(I,J) = CMGR_URB
- CHGR_SFCDIF(I,J) = CHGR_URB
- CMC_SFCDIF(I,J) = CMC_URB
- CHC_SFCDIF(I,J) = CHC_URB
- ENDIF
-
- ! 2D to 3D mosaic danli
-
- TR_URB2D_mosaic(I,mosaic_i,J)=TR_URB2D(I,J)
- TB_URB2D_mosaic(I,mosaic_i,J)=TB_URB2D(I,J)
- TG_URB2D_mosaic(I,mosaic_i,J)=TG_URB2D(I,J)
- TC_URB2D_mosaic(I,mosaic_i,J)=TC_URB2D(I,J)
- QC_URB2D_mosaic(I,mosaic_i,J)=QC_URB2D(I,J)
- UC_URB2D_mosaic(I,mosaic_i,J)=UC_URB2D(I,J)
- TS_URB2D_mosaic(I,mosaic_i,J)=TS_URB2D(I,J)
- TS_RUL2D_mosaic(I,mosaic_i,J)=T1
-
- DO K = 1,num_roof_layers
- TRL_URB3D_mosaic(I,K+(mosaic_i-1)*num_roof_layers,J)=TRL_URB3D(I,K,J)
- END DO
- DO K = 1,num_wall_layers
- TBL_URB3D_mosaic(I,K+(mosaic_i-1)*num_roof_layers,J)=TBL_URB3D(I,K,J)
- END DO
- DO K = 1,num_road_layers
- TGL_URB3D_mosaic(I,K+(mosaic_i-1)*num_roof_layers,J)=TGL_URB3D(I,K,J)
- END DO
-
- SH_URB2D_mosaic(I,mosaic_i,J) = SH_URB2D(I,J)
- LH_URB2D_mosaic(I,mosaic_i,J) = LH_URB2D(I,J)
- G_URB2D_mosaic(I,mosaic_i,J) = G_URB2D(I,J)
- RN_URB2D_mosaic(I,mosaic_i,J) = RN_URB2D(I,J)
-
- END IF
-
- ENDIF ! end of UCM CALL if block
- !--------------------------------------
- ! Urban Part End - urban
- !--------------------------------------
-
- !*** DIAGNOSTICS
- SMSTAV(I,J)=SOILW
- SMSTOT(I,J)=SOILM*1000.
- DO NS=1,NSOIL
- SMCREL(I,NS,J)=SMAV(NS)
- ENDDO
-
- ! Convert the water unit into mm
- SFCRUNOFF(I,J)=SFCRUNOFF(I,J)+RUNOFF1*DT*1000.0
- UDRUNOFF(I,J)=UDRUNOFF(I,J)+RUNOFF2*DT*1000.0
- ! snow defined when fraction of frozen precip (FFROZP) > 0.5,
- IF(FFROZP.GT.0.5)THEN
- ACSNOW(I,J)=ACSNOW(I,J)+PRCP*DT
- ENDIF
- IF(SNOW(I,J).GT.0.)THEN
- ACSNOM(I,J)=ACSNOM(I,J)+SNOMLT*1000.
- ! accumulated snow-melt energy
- SNOPCX(I,J)=SNOPCX(I,J)-SNOMLT/FDTLIW
- ENDIF
-
- ENDIF ! endif of land-sea test
-
- !-----------------------------------------------------------------------
- ! Done with the Noah-UCM MOSAIC DANLI
- !-----------------------------------------------------------------------
-
- TSK_mosaic(i,mosaic_i,j)=TSK(i,j) ! from 2D to 3D
- QSFC_mosaic(i,mosaic_i,j)=QSFC(i,j)
- CANWAT_mosaic(i,mosaic_i,j)=CANWAT(i,j)
- SNOW_mosaic(i,mosaic_i,j)=SNOW(i,j)
- SNOWH_mosaic(i,mosaic_i,j)=SNOWH(i,j)
- SNOWC_mosaic(i,mosaic_i,j)=SNOWC(i,j)
-
- ALBEDO_mosaic(i,mosaic_i,j)=ALBEDO(i,j)
- ALBBCK_mosaic(i,mosaic_i,j)=ALBBCK(i,j)
- EMISS_mosaic(i,mosaic_i,j)=EMISS(i,j)
- EMBCK_mosaic(i,mosaic_i,j)=EMBCK(i,j)
- ZNT_mosaic(i,mosaic_i,j)=ZNT(i,j)
- Z0_mosaic(i,mosaic_i,j)=Z0(i,j)
- LAI_mosaic(i,mosaic_i,j)=XLAI
- RC_mosaic(i,mosaic_i,j)=RC
-
- HFX_mosaic(i,mosaic_i,j)=HFX(i,j)
- QFX_mosaic(i,mosaic_i,j)=QFX(i,j)
- LH_mosaic(i,mosaic_i,j)=LH(i,j)
- GRDFLX_mosaic(i,mosaic_i,j)=GRDFLX(i,j)
- SNOTIME_mosaic(i,mosaic_i,j)=SNOTIME(i,j)
-
- DO NS=1,NSOIL
-
- TSLB_mosaic(i,NSOIL*(mosaic_i-1)+NS,j)=TSLB(i,NS,j)
- SMOIS_mosaic(i,NSOIL*(mosaic_i-1)+NS,j)=SMOIS(i,NS,j)
- SH2O_mosaic(i,NSOIL*(mosaic_i-1)+NS,j)=SH2O(i,NS,j)
-
- ENDDO
-
-#if 0
- IF(TSK_mosaic(i,mosaic_i,j) > 350 .OR. TSK_mosaic(i,mosaic_i,j) < 250 .OR. abs(HFX_mosaic(i,mosaic_i,j)) > 700 ) THEN
- print*, 'I', I, 'J', J, 'MOSAIC_I', MOSAIC_I
- print*, 'mosaic_cat_index',mosaic_cat_index(I,mosaic_i,J), 'landusef2',landusef2(i,mosaic_i,j)
- print*, 'TSK_mosaic', TSK_mosaic(i,mosaic_i,j), 'HFX_mosaic', HFX_mosaic(i,mosaic_i,j), &
- 'LH_mosaic',LH_mosaic(i,mosaic_i,j),'GRDFLX_mosaic',GRDFLX_mosaic(i,mosaic_i,j)
- print*, 'ZNT_mosaic', ZNT_mosaic(i, mosaic_i,j), 'Z0_mosaic', Z0_mosaic(i,mosaic_i,j)
- print*, 'LAI_mosaic', LAI_mosaic(i, mosaic_i,j)
- print*, 'FRC_URB2D',FRC_URB2D(I,J)
- print*, 'TS_URB',TS_URB2D(I,J),'T1',T1
- print*, 'SH_URB2D',SH_URB2D(I,J),'SHEAT',SHEAT
- print*, 'LH_URB',LH_URB2D(I,J),'ETA',ETA
- print*, 'TS_RUL2D',TS_RUL2D_mosaic(I,mosaic_i,J)
-
- ENDIF
-#endif
-
- !-----------------------------------------------------------------------
- ! Now let's do the grid-averaging
- !-----------------------------------------------------------------------
-
- FAREA = landusef2(i,mosaic_i,j)
-
- TSK_mosaic_avg(i,j) = TSK_mosaic_avg(i,j) + (EMISS_mosaic(i,mosaic_i,j)*TSK_mosaic(i,mosaic_i,j)**4)*FAREA ! conserve the longwave radiation
-
- QSFC_mosaic_avg(i,j) = QSFC_mosaic_avg(i,j) + QSFC_mosaic(i,mosaic_i,j)*FAREA
- CANWAT_mosaic_avg(i,j) = CANWAT_mosaic_avg(i,j) + CANWAT_mosaic(i,mosaic_i,j)*FAREA
- SNOW_mosaic_avg(i,j) = SNOW_mosaic_avg(i,j) + SNOW_mosaic(i,mosaic_i,j)*FAREA
- SNOWH_mosaic_avg(i,j) = SNOWH_mosaic_avg(i,j) + SNOWH_mosaic(i,mosaic_i,j)*FAREA
- SNOWC_mosaic_avg(i,j) = SNOWC_mosaic_avg(i,j) + SNOWC_mosaic(i,mosaic_i,j)*FAREA
-
- DO NS=1,NSOIL
-
- TSLB_mosaic_avg(i,NS,j)=TSLB_mosaic_avg(i,NS,j) + TSLB_mosaic(i,NS*mosaic_i,j)*FAREA
- SMOIS_mosaic_avg(i,NS,j)=SMOIS_mosaic_avg(i,NS,j) + SMOIS_mosaic(i,NS*mosaic_i,j)*FAREA
- SH2O_mosaic_avg(i,NS,j)=SH2O_mosaic_avg(i,NS,j) + SH2O_mosaic(i,NS*mosaic_i,j)*FAREA
-
- ENDDO
-
- FAREA_mosaic_avg(i,j)=FAREA_mosaic_avg(i,j)+FAREA
- HFX_mosaic_avg(i,j) = HFX_mosaic_avg(i,j) + HFX_mosaic(i,mosaic_i,j)*FAREA
- QFX_mosaic_avg(i,j) = QFX_mosaic_avg(i,j) + QFX_mosaic(i,mosaic_i,j)*FAREA
- LH_mosaic_avg(i,j) = LH_mosaic_avg(i,j) + LH_mosaic(i,mosaic_i,j)*FAREA
- GRDFLX_mosaic_avg(i,j)=GRDFLX_mosaic_avg(i,j)+GRDFLX_mosaic(i,mosaic_i,j)*FAREA
-
- ALBEDO_mosaic_avg(i,j)=ALBEDO_mosaic_avg(i,j)+ALBEDO_mosaic(i,mosaic_i,j)*FAREA
- ALBBCK_mosaic_avg(i,j)=ALBBCK_mosaic_avg(i,j)+ALBBCK_mosaic(i,mosaic_i,j)*FAREA
- EMISS_mosaic_avg(i,j)=EMISS_mosaic_avg(i,j)+EMISS_mosaic(i,mosaic_i,j)*FAREA
- EMBCK_mosaic_avg(i,j)=EMBCK_mosaic_avg(i,j)+EMBCK_mosaic(i,mosaic_i,j)*FAREA
- ZNT_mosaic_avg(i,j)=ZNT_mosaic_avg(i,j)+ALOG(ZNT_mosaic(i,mosaic_i,j))*FAREA
- Z0_mosaic_avg(i,j)=Z0_mosaic_avg(i,j)+ALOG(Z0_mosaic(i,mosaic_i,j))*FAREA
- LAI_mosaic_avg(i,j)=LAI_mosaic_avg(i,j)+LAI_mosaic(i,mosaic_i,j)*FAREA
- if(RC_mosaic(i,mosaic_i,j) .Gt. 0.0) Then
- RC_mosaic_avg(i,j) = RC_mosaic_avg(i,j)+1.0/RC_mosaic(i,mosaic_i,j)*FAREA
- else
- RC_mosaic_avg(i,j) = RC_mosaic_avg(i,j) + RC_mosaic(i,mosaic_i,j)*FAREA
- End If
- ENDDO ! ENDDO FOR mosaic_i = 1, mosaic_cat
-
- !-----------------------------------------------------------------------
- ! Now let's send the 3D values to the 2D variables that might be needed in other routines
- !-----------------------------------------------------------------------
-
- IVGTYP(I,J)=IVGTYP_dominant(I,J) ! the dominant vege category
- ALBEDO(i,j)=ALBEDO_mosaic_avg(i,j)
- ALBBCK(i,j)=ALBBCK_mosaic_avg(i,j)
- EMISS(i,j)= EMISS_mosaic_avg(i,j)
- EMBCK(i,j)= EMBCK_mosaic_avg(i,j)
- ZNT(i,j)= EXP(ZNT_mosaic_avg(i,j)/FAREA_mosaic_avg(i,j))
- Z0(i,j)= EXP(Z0_mosaic_avg(i,j)/FAREA_mosaic_avg(i,j))
- XLAI2(i,j)= LAI_mosaic_avg(i,j)
- IF (RC_mosaic_avg(i,j) .Gt. 0.0) THEN
- rc2(i,j) = 1.0/(RC_mosaic_avg(i,j))
- ELSE
-!RC_mosaic_avg was zero for all tiles (cell over water), thus RC2 set to zero to avoid infinity
- rc2(i,j) = RC_mosaic_avg(i,j)
- END IF
- TSK(i,j)=(TSK_mosaic_avg(I,J)/EMISS_mosaic_avg(I,J))**(0.25) ! from 3D to 2D
- QSFC(i,j)=QSFC_mosaic_avg(I,J)
- CANWAT(i,j) = CANWAT_mosaic_avg(i,j)
- SNOW(i,j) = SNOW_mosaic_avg(i,j)
- SNOWH(i,j) = SNOWH_mosaic_avg(i,j)
- SNOWC(i,j) = SNOWC_mosaic_avg(i,j)
-
- HFX(i,j) = HFX_mosaic_avg(i,j)
- QFX(i,j) = QFX_mosaic_avg(i,j)
- LH(i,j) = LH_mosaic_avg(i,j)
- GRDFLX(i,j)=GRDFLX_mosaic_avg(i,j)
-
- DO NS=1,NSOIL
-
- TSLB(i,NS,j)=TSLB_mosaic_avg(i,NS,j)
- SMOIS(i,NS,j)=SMOIS_mosaic_avg(i,NS,j)
- SH2O(i,NS,j)=SH2O_mosaic_avg(i,NS,j)
-
- ENDDO
-
- ELSE ! This corresponds to IF ((sf_surface_mosaic == 1) .AND. ((XLAND(I,J)-1.5).LT.0.) .AND. (XICE(I,J) < XICE_THRESHOLD) ) THEN
-
- ! surface pressure
- PSFC=P8w3D(i,1,j)
- ! pressure in middle of lowest layer
- SFCPRS=(P8W3D(I,KTS+1,j)+P8W3D(i,KTS,j))*0.5
- ! convert from mixing ratio to specific humidity
- Q2K=QV3D(i,1,j)/(1.0+QV3D(i,1,j))
- !
- ! Q2SAT=QGH(I,j)
- Q2SAT=QGH(I,J)/(1.0+QGH(I,J)) ! Q2SAT is sp humidity
- ! add check on myj=.true.
- ! IF((Q2K.GE.Q2SAT*TRESH).AND.Q2K.LT.QZ0(I,J))THEN
- IF((myj).AND.(Q2K.GE.Q2SAT*TRESH).AND.Q2K.LT.QZ0(I,J))THEN
- SATFLG=0.
- CHKLOWQ(I,J)=0.
- ELSE
- SATFLG=1.0
- CHKLOWQ(I,J)=1.
- ENDIF
-
- SFCTMP=T3D(i,1,j)
- ZLVL=0.5*DZ8W(i,1,j)
-
- ! TH2=SFCTMP+(0.0097545*ZLVL)
- ! calculate SFCTH2 via Exner function vs lapse-rate (above)
- APES=(1.E5/PSFC)**CAPA
- APELM=(1.E5/SFCPRS)**CAPA
- SFCTH2=SFCTMP*APELM
- TH2=SFCTH2/APES
- !
- EMISSI = EMISS(I,J)
- LWDN=GLW(I,J)*EMISSI
- ! SOLDN is total incoming solar
- SOLDN=SWDOWN(I,J)
- ! GSW is net downward solar
- ! SOLNET=GSW(I,J)
- ! use mid-day albedo to determine net downward solar (no solar zenith angle correction)
- SOLNET=SOLDN*(1.-ALBEDO(I,J))
- PRCP=RAINBL(i,j)/DT
- VEGTYP=IVGTYP(I,J)
- SOILTYP=ISLTYP(I,J)
- SHDFAC=VEGFRA(I,J)/100.
- T1=TSK(I,J)
- CHK=CHS(I,J)
- SHMIN=SHDMIN(I,J)/100. !NEW
- SHMAX=SHDMAX(I,J)/100. !NEW
- ! convert snow water equivalent from mm to meter
- SNEQV=SNOW(I,J)*0.001
- ! snow depth in meters
- SNOWHK=SNOWH(I,J)
- SNCOVR=SNOWC(I,J)
-
- ! if "SR" present, set frac of frozen precip ("FFROZP") = snow-ratio ("SR", range:0-1)
- ! SR from e.g. Ferrier microphysics
- ! otherwise define from 1st atmos level temperature
- IF(FRPCPN) THEN
- FFROZP=SR(I,J)
- ELSE
- IF (SFCTMP <= 273.15) THEN
- FFROZP = 1.0
- ELSE
- FFROZP = 0.0
- ENDIF
- ENDIF
- !***
- IF((XLAND(I,J)-1.5).GE.0.)THEN ! begining of land/sea if block
- ! Open water points
- TSK_RURAL(I,J)=TSK(I,J)
- HFX_RURAL(I,J)=HFX(I,J)
- QFX_RURAL(I,J)=QFX(I,J)
- LH_RURAL(I,J)=LH(I,J)
- EMISS_RURAL(I,J)=EMISS(I,J)
- GRDFLX_RURAL(I,J)=GRDFLX(I,J)
- ELSE
- ! Land or sea-ice case
-
- IF (XICE(I,J) >= XICE_THRESHOLD) THEN
- ! Sea-ice point
- ICE = 1
- ELSE IF ( VEGTYP == ISICE ) THEN
- ! Land-ice point
- ICE = -1
- ELSE
- ! Neither sea ice or land ice.
- ICE=0
- ENDIF
- DQSDT2=Q2SAT*A23M4/(SFCTMP-A4)**2
-
- IF(SNOW(I,J).GT.0.0)THEN
- ! snow on surface (use ice saturation properties)
- SFCTSNO=SFCTMP
- E2SAT=611.2*EXP(6174.*(1./273.15 - 1./SFCTSNO))
- Q2SATI=0.622*E2SAT/(SFCPRS-E2SAT)
- Q2SATI=Q2SATI/(1.0+Q2SATI) ! spec. hum.
- IF (T1 .GT. 273.14) THEN
- ! warm ground temps, weight the saturation between ice and water according to SNOWC
- Q2SAT=Q2SAT*(1.-SNOWC(I,J)) + Q2SATI*SNOWC(I,J)
- DQSDT2=DQSDT2*(1.-SNOWC(I,J)) + Q2SATI*6174./(SFCTSNO**2)*SNOWC(I,J)
- ELSE
- ! cold ground temps, use ice saturation only
- Q2SAT=Q2SATI
- DQSDT2=Q2SATI*6174./(SFCTSNO**2)
- ENDIF
- ! for snow cover fraction at 0 C, ground temp will not change, so DQSDT2 effectively zero
- IF(T1 .GT. 273. .AND. SNOWC(I,J) .GT. 0.)DQSDT2=DQSDT2*(1.-SNOWC(I,J))
- ENDIF
-
- ! Land-ice or land points use the usual deep-soil temperature.
- TBOT=TMN(I,J)
-
- IF(VEGTYP.EQ.25) SHDFAC=0.0000
- IF(VEGTYP.EQ.26) SHDFAC=0.0000
- IF(VEGTYP.EQ.27) SHDFAC=0.0000
- IF(SOILTYP.EQ.14.AND.XICE(I,J).EQ.0.)THEN
-#if 0
- IF(IPRINT)PRINT*,' SOIL TYPE FOUND TO BE WATER AT A LAND-POINT'
- IF(IPRINT)PRINT*,i,j,'RESET SOIL in surfce.F'
-#endif
- SOILTYP=7
- ENDIF
- SNOALB1 = SNOALB(I,J)
- CMC=CANWAT(I,J)/1000.
-
- !-------------------------------------------
- !*** convert snow depth from mm to meter
- !
- ! IF(RDMAXALB) THEN
- ! SNOALB=ALBMAX(I,J)*0.01
- ! ELSE
- ! SNOALB=MAXALB(IVGTPK)*0.01
- ! ENDIF
-
- ! SNOALB1=0.80
- ! SHMIN=0.00
- ALBBRD=ALBBCK(I,J)
- Z0BRD=Z0(I,J)
- EMBRD=EMBCK(I,J)
- SNOTIME1 = SNOTIME(I,J)
- RIBB=RIB(I,J)
- !FEI: temporaray arrays above need to be changed later by using SI
-
- DO NS=1,NSOIL
- SMC(NS)=SMOIS(I,NS,J)
- STC(NS)=TSLB(I,NS,J) !STEMP
- SWC(NS)=SH2O(I,NS,J)
- ENDDO
- !
- if ( (SNEQV.ne.0..AND.SNOWHK.eq.0.).or.(SNOWHK.le.SNEQV) )THEN
- SNOWHK= 5.*SNEQV
- endif
- !
-
- !Fei: urban. for urban surface, if calling UCM, redefine the natural surface in cities as
- ! the "NATURAL" category in the VEGPARM.TBL
- IF(SF_URBAN_PHYSICS == 1.OR. SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN
-
- IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. &
- IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. &
- IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. &
- IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN
-
- VEGTYP = NATURAL
- SHDFAC = SHDTBL(NATURAL)
- ALBEDOK =0.2 ! 0.2
- ALBBRD =0.2 !0.2
- EMISSI = 0.98 !for VEGTYP=5
- IF ( FRC_URB2D(I,J) < 0.99 ) THEN
- if(sf_urban_physics.eq.1)then
- T1= ( TSK(I,J) -FRC_URB2D(I,J) * TS_URB2D (I,J) )/ (1-FRC_URB2D(I,J))
- elseif((sf_urban_physics.eq.2).OR.(sf_urban_physics.eq.3))then
- T1=tsk_rural_bep(i,j)
- endif
- ELSE
- T1 = TSK(I,J)
- ENDIF
- ENDIF
- ELSE
- IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. &
- IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. &
- IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. &
- IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN
- VEGTYP = ISURBAN
- ENDIF
- ENDIF
-
-
-!===Yang, 2014/10/08, hydrological processes for urban vegetation in single layer UCM===
- AOASIS = 1.0
- USOIL = 1
- DSOIL = 2
- IRIOPTION=IRI_SCHEME
- OMG= OMG_URB2D(I,J)
- tloc=mod(int(OMG/3.14159*180./15.+12.+0.5 ),24)
- if (tloc.lt.0) tloc=tloc+24
- if (tloc==0) tloc=24
- CALL cal_mon_day(julian,julyr,jmonth,jday)
- IF(SF_URBAN_PHYSICS == 1) THEN
- IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. &
- IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. &
- IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. &
- IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN
-
- AOASIS = oasis ! urban oasis effect
- IF (IRIOPTION ==1) THEN
- IF (tloc==21 .or. tloc==22) THEN !irrigation on vegetaion in urban area, MAY-SEP, 9-10pm
- IF (jmonth==5 .or. jmonth==6 .or. jmonth==7 .or. jmonth==8 .or. jmonth==9) THEN
- IF (SMC(USOIL) .LT. SMCREF) SMC(USOIL)= REFSMC(ISLTYP(I,J))
- IF (SMC(DSOIL) .LT. SMCREF) SMC(DSOIL)= REFSMC(ISLTYP(I,J))
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- ENDIF
-
- IF(SF_URBAN_PHYSICS == 2 .or. SF_URBAN_PHYSICS == 3) THEN
- IF(AOASIS > 1.0) THEN
- CALL wrf_error_fatal('Urban oasis option is for SF_URBAN_PHYSICS == 1 only')
- ENDIF
- IF(IRIOPTION == 1) THEN
- CALL wrf_error_fatal('Urban irrigation option is for SF_URBAN_PHYSICS == 1 only')
- ENDIF
- ENDIF
-
-#if 0
- IF(IPRINT) THEN
- !
- print*, 'BEFORE SFLX, in Noahlsm_driver'
- print*, 'ICE', ICE, 'DT',DT, 'ZLVL',ZLVL, 'NSOIL', NSOIL, &
- 'SLDPTH', SLDPTH, 'LOCAL',LOCAL, 'LUTYPE',&
- LUTYPE, 'SLTYPE',SLTYPE, 'LWDN',LWDN, 'SOLDN',SOLDN, &
- 'SFCPRS',SFCPRS, 'PRCP',PRCP,'SFCTMP',SFCTMP,'Q2K',Q2K, &
- 'TH2',TH2,'Q2SAT',Q2SAT,'DQSDT2',DQSDT2,'VEGTYP', VEGTYP,&
- 'SOILTYP',SOILTYP, 'SLOPETYP',SLOPETYP, 'SHDFAC',SHDFAC,&
- 'SHMIN',SHMIN, 'ALBBRD',ALBBRD,'SNOALB1',SNOALB1,'TBOT',&
- TBOT, 'Z0BRD',Z0BRD, 'Z0K',Z0K, 'CMC',CMC, 'T1',T1,'STC',&
- STC, 'SMC',SMC, 'SWC',SWC,'SNOWHK',SNOWHK,'SNEQV',SNEQV,&
- 'ALBEDOK',ALBEDOK,'CHK',CHK,'ETA',ETA,'SHEAT',SHEAT, &
- 'ETA_KINEMATIC',ETA_KINEMATIC, 'FDOWN',FDOWN,'EC',EC, &
- 'EDIR',EDIR,'ET',ET,'ETT',ETT,'ESNOW',ESNOW,'DRIP',DRIP,&
- 'DEW',DEW,'BETA',BETA,'ETP',ETP,'SSOIL',SSOIL,'FLX1',FLX1,&
- 'FLX2',FLX2,'FLX3',FLX3,'SNOMLT',SNOMLT,'SNCOVR',SNCOVR,&
- 'RUNOFF1',RUNOFF1,'RUNOFF2',RUNOFF2,'RUNOFF3',RUNOFF3, &
- 'RC',RC, 'PC',PC,'RSMIN',RSMIN,'XLAI',XLAI,'RCS',RCS, &
- 'RCT',RCT,'RCQ',RCQ,'RCSOIL',RCSOIL,'SOILW',SOILW, &
- 'SOILM',SOILM,'Q1',Q1,'SMCWLT',SMCWLT,'SMCDRY',SMCDRY,&
- 'SMCREF',SMCREF,'SMCMAX',SMCMAX,'NROOT',NROOT
- endif
-#endif
-
- IF (rdlai2d) THEN
- xlai = lai(i,j)
- endif
-
- IF ( ICE == 1 ) THEN
-
- ! Sea-ice case
-
- DO NS = 1, NSOIL
- SH2O(I,NS,J) = 1.0
- ENDDO
- LAI(I,J) = 0.01
-
- CYCLE ILOOP
-
- ELSEIF (ICE == 0) THEN
-
- ! Non-glacial land
-
- CALL SFLX (I,J,FFROZP, ISURBAN, DT,ZLVL,NSOIL,SLDPTH, & !C
- LOCAL, & !L
- LUTYPE, SLTYPE, & !CL
- LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K,DUMMY, & !F
- DUMMY,DUMMY, DUMMY, & !F PRCPRAIN not used
- TH2,Q2SAT,DQSDT2, & !I
- VEGTYP,SOILTYP,SLOPETYP,SHDFAC,SHMIN,SHMAX, & !I
- ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, & !S
- CMC,T1,STC,SMC,SWC,SNOWHK,SNEQV,ALBEDOK,CHK,dummy,& !H
- ETA,SHEAT, ETA_KINEMATIC,FDOWN, & !O
- EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, & !O
- BETA,ETP,SSOIL, & !O
- FLX1,FLX2,FLX3, & !O
- FLX4,FVB,FBUR,FGSN,UA_PHYS, & !UA
- SNOMLT,SNCOVR, & !O
- RUNOFF1,RUNOFF2,RUNOFF3, & !O
- RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, & !O
- SOILW,SOILM,Q1,SMAV, & !D
- RDLAI2D,USEMONALB, &
- SNOTIME1, &
- RIBB, &
- SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT, &
- sfcheadrt(i,j), & !I
- INFXSRT(i,j),ETPND1,OPT_THCND,AOASIS & !O
- ,XSDA_QFX, HFX_PHY, QFX_PHY, XQNORM, fasdas, HCPCT_FASDAS & ! fasdas vars
- ,IRRIGATION_CHANNEL )
-
-#ifdef WRF_HYDRO
- soldrain(i,j) = RUNOFF2*DT*1000.0
-#endif
- ELSEIF (ICE == -1) THEN
-
- !
- ! Set values that the LSM is expected to update,
- ! but don't get updated for glacial points.
- !
- SOILM = 0.0 !BSINGH(PNNL)- SOILM is undefined for this case, it is used for diagnostics so setting it to zero
- XLAI = 0.01 ! KWM Should this be Zero over land ice? Does this value matter?
- RUNOFF2 = 0.0
- RUNOFF3 = 0.0
- DO NS = 1, NSOIL
- SWC(NS) = 1.0
- SMC(NS) = 1.0
- SMAV(NS) = 1.0
- ENDDO
- CALL SFLX_GLACIAL(I,J,ISICE,FFROZP,DT,ZLVL,NSOIL,SLDPTH, & !C
- & LWDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K, & !F
- & TH2,Q2SAT,DQSDT2, & !I
- & ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, & !S
- & T1,STC(1:NSOIL),SNOWHK,SNEQV,ALBEDOK,CHK, & !H
- & ETA,SHEAT,ETA_KINEMATIC,FDOWN, & !O
- & ESNOW,DEW, & !O
- & ETP,SSOIL, & !O
- & FLX1,FLX2,FLX3, & !O
- & SNOMLT,SNCOVR, & !O
- & RUNOFF1, & !O
- & Q1, & !D
- & SNOTIME1, &
- & RIBB)
-
- ENDIF
-
- lai(i,j) = xlai
-
-#if 0
- IF(IPRINT) THEN
-
- print*, 'AFTER SFLX, in Noahlsm_driver'
- print*, 'ICE', ICE, 'DT',DT, 'ZLVL',ZLVL, 'NSOIL', NSOIL, &
- 'SLDPTH', SLDPTH, 'LOCAL',LOCAL, 'LUTYPE',&
- LUTYPE, 'SLTYPE',SLTYPE, 'LWDN',LWDN, 'SOLDN',SOLDN, &
- 'SFCPRS',SFCPRS, 'PRCP',PRCP,'SFCTMP',SFCTMP,'Q2K',Q2K, &
- 'TH2',TH2,'Q2SAT',Q2SAT,'DQSDT2',DQSDT2,'VEGTYP', VEGTYP,&
- 'SOILTYP',SOILTYP, 'SLOPETYP',SLOPETYP, 'SHDFAC',SHDFAC,&
- 'SHDMIN',SHMIN, 'ALBBRD',ALBBRD,'SNOALB',SNOALB1,'TBOT',&
- TBOT, 'Z0BRD',Z0BRD, 'Z0K',Z0K, 'CMC',CMC, 'T1',T1,'STC',&
- STC, 'SMC',SMC, 'SWc',SWC,'SNOWHK',SNOWHK,'SNEQV',SNEQV,&
- 'ALBEDOK',ALBEDOK,'CHK',CHK,'ETA',ETA,'SHEAT',SHEAT, &
- 'ETA_KINEMATIC',ETA_KINEMATIC, 'FDOWN',FDOWN,'EC',EC, &
- 'EDIR',EDIR,'ET',ET,'ETT',ETT,'ESNOW',ESNOW,'DRIP',DRIP,&
- 'DEW',DEW,'BETA',BETA,'ETP',ETP,'SSOIL',SSOIL,'FLX1',FLX1,&
- 'FLX2',FLX2,'FLX3',FLX3,'SNOMLT',SNOMLT,'SNCOVR',SNCOVR,&
- 'RUNOFF1',RUNOFF1,'RUNOFF2',RUNOFF2,'RUNOFF3',RUNOFF3, &
- 'RC',RC, 'PC',PC,'RSMIN',RSMIN,'XLAI',XLAI,'RCS',RCS, &
- 'RCT',RCT,'RCQ',RCQ,'RCSOIL',RCSOIL,'SOILW',SOILW, &
- 'SOILM',SOILM,'Q1',Q1,'SMCWLT',SMCWLT,'SMCDRY',SMCDRY,&
- 'SMCREF',SMCREF,'SMCMAX',SMCMAX,'NROOT',NROOT
- endif
-#endif
-
- !*** UPDATE STATE VARIABLES
- CANWAT(I,J)=CMC*1000.
- SNOW(I,J)=SNEQV*1000.
- ! SNOWH(I,J)=SNOWHK*1000.
- SNOWH(I,J)=SNOWHK ! SNOWHK in meters
- ALBEDO(I,J)=ALBEDOK
- ALB_RURAL(I,J)=ALBEDOK
- ALBBCK(I,J)=ALBBRD
- Z0(I,J)=Z0BRD
- EMISS(I,J) = EMISSI
- EMISS_RURAL(I,J) = EMISSI
- ! Noah: activate time-varying roughness length (V3.3 Feb 2011)
- ZNT(I,J)=Z0K
- TSK(I,J)=T1
- TSK_RURAL(I,J)=T1
- HFX(I,J)=SHEAT
- HFX_RURAL(I,J)=SHEAT
- ! MEk Jul07 add potential evap accum
- POTEVP(I,J)=POTEVP(I,J)+ETP*FDTW
- QFX(I,J)=ETA_KINEMATIC
- QFX_RURAL(I,J)=ETA_KINEMATIC
-
-#ifdef WRF_HYDRO
- !added by Wei Yu
- ! QFX(I,J) = QFX(I,J) + ETPND1
- ! ETA = ETA + ETPND1/2.501E6*dt
- !end added by Wei Yu
-#endif
-
- LH(I,J)=ETA
- LH_RURAL(I,J)=ETA
- GRDFLX(I,J)=SSOIL
- GRDFLX_RURAL(I,J)=SSOIL
- SNOWC(I,J)=SNCOVR
- CHS2(I,J)=CQS2(I,J)
- SNOTIME(I,J) = SNOTIME1
- ! prevent diagnostic ground q (q1) from being greater than qsat(tsk)
- ! as happens over snow cover where the cqs2 value also becomes irrelevant
- ! by setting cqs2=chs in this situation the 2m q should become just qv(k=1)
- IF (Q1 .GT. QSFC(I,J)) THEN
- CQS2(I,J) = CHS(I,J)
- ENDIF
- ! QSFC(I,J)=Q1
- ! Convert QSFC back to mixing ratio
- QSFC(I,J)= Q1/(1.0-Q1)
- !
- ! QSFC_RURAL(I,J)= Q1/(1.0-Q1)
- ! Calculate momentum flux from rural surface for use with multi-layer UCM (Martilli et al. 2002)
-
- DO 80 NS=1,NSOIL
- SMOIS(I,NS,J)=SMC(NS)
- TSLB(I,NS,J)=STC(NS) ! STEMP
- SH2O(I,NS,J)=SWC(NS)
- 80 CONTINUE
- ! ENDIF
-
- FLX4_2D(I,J) = FLX4
- FVB_2D(I,J) = FVB
- FBUR_2D(I,J) = FBUR
- FGSN_2D(I,J) = FGSN
- !
- ! Residual of surface energy balance equation terms
- !
-
- IF ( UA_PHYS ) THEN
- noahres(i,j) = ( solnet + lwdn ) - sheat + ssoil - eta &
- - ( emissi * STBOLT * (t1**4) ) - flx1 - flx2 - flx3 - flx4
-
- ELSE
- noahres(i,j) = ( solnet + lwdn ) - sheat + ssoil - eta &
- - ( emissi * STBOLT * (t1**4) ) - flx1 - flx2 - flx3
- ENDIF
-
- IF (SF_URBAN_PHYSICS == 1 ) THEN ! Beginning of UCM CALL if block
- !--------------------------------------
- ! URBAN CANOPY MODEL START - urban
- !--------------------------------------
- ! Input variables lsm --> urban
- IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. &
- IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. &
- IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. &
- IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN
-
-
- ! Call urban
- !
- UTYPE_URB = UTYPE_URB2D(I,J) !urban type (low, high or industrial)
-
- TA_URB = SFCTMP ! [K]
- QA_URB = Q2K ! [kg/kg]
- UA_URB = SQRT(U_PHY(I,1,J)**2.+V_PHY(I,1,J)**2.)
- U1_URB = U_PHY(I,1,J)
- V1_URB = V_PHY(I,1,J)
- IF(UA_URB < 1.) UA_URB=1. ! [m/s]
- SSG_URB = SOLDN ! [W/m/m]
- SSGD_URB = 0.8*SOLDN ! [W/m/m]
- SSGQ_URB = SSG_URB-SSGD_URB ! [W/m/m]
- LLG_URB = GLW(I,J) ! [W/m/m]
- RAIN_URB = RAINBL(I,J) ! [mm]
- RHOO_URB = SFCPRS / (287.04 * SFCTMP * (1.0+ 0.61 * Q2K)) ![kg/m/m/m]
- ZA_URB = ZLVL ! [m]
- DELT_URB = DT ! [sec]
- XLAT_URB = XLAT_URB2D(I,J) ! [deg]
- COSZ_URB = COSZ_URB2D(I,J) !
- OMG_URB = OMG_URB2D(I,J) !
- ZNT_URB = ZNT(I,J)
-
- LSOLAR_URB = .FALSE.
-
- TR_URB = TR_URB2D(I,J)
- TB_URB = TB_URB2D(I,J)
- TG_URB = TG_URB2D(I,J)
- TC_URB = TC_URB2D(I,J)
- QC_URB = QC_URB2D(I,J)
- UC_URB = UC_URB2D(I,J)
-
- DO K = 1,num_roof_layers
- TRL_URB(K) = TRL_URB3D(I,K,J)
- SMR_URB(K) = SMR_URB3D(I,K,J)
- TGRL_URB(K)= TGRL_URB3D(I,K,J)
- END DO
- DO K = 1,num_wall_layers
- TBL_URB(K) = TBL_URB3D(I,K,J)
- END DO
- DO K = 1,num_road_layers
- TGL_URB(K) = TGL_URB3D(I,K,J)
- END DO
-
- TGR_URB = TGR_URB2D(I,J)
- CMCR_URB = CMCR_URB2D(I,J)
- FLXHUMR_URB = FLXHUMR_URB2D(I,J)
- FLXHUMB_URB = FLXHUMB_URB2D(I,J)
- FLXHUMG_URB = FLXHUMG_URB2D(I,J)
- DRELR_URB = DRELR_URB2D(I,J)
- DRELB_URB = DRELB_URB2D(I,J)
- DRELG_URB = DRELG_URB2D(I,J)
-
- XXXR_URB = XXXR_URB2D(I,J)
- XXXB_URB = XXXB_URB2D(I,J)
- XXXG_URB = XXXG_URB2D(I,J)
- XXXC_URB = XXXC_URB2D(I,J)
- !
- ! Limits to avoid dividing by small number
- if (CHS(I,J) < 1.0E-02) then
- CHS(I,J) = 1.0E-02
- endif
- if (CHS2(I,J) < 1.0E-02) then
- CHS2(I,J) = 1.0E-02
- endif
- if (CQS2(I,J) < 1.0E-02) then
- CQS2(I,J) = 1.0E-02
- endif
- !
- CHS_URB = CHS(I,J)
- CHS2_URB = CHS2(I,J)
- IF (PRESENT(CMR_SFCDIF)) THEN
- CMR_URB = CMR_SFCDIF(I,J)
- CHR_URB = CHR_SFCDIF(I,J)
- CMGR_URB = CMGR_SFCDIF(I,J)
- CHGR_URB = CHGR_SFCDIF(I,J)
- CMC_URB = CMC_SFCDIF(I,J)
- CHC_URB = CHC_SFCDIF(I,J)
- ENDIF
-
- ! NUDAPT for SLUCM
- mh_urb = mh_urb2d(I,J)
- stdh_urb = stdh_urb2d(I,J)
- lp_urb = lp_urb2d(I,J)
- hgt_urb = hgt_urb2d(I,J)
- lf_urb = 0.0
- DO K = 1,4
- lf_urb(K)=lf_urb2d(I,K,J)
- ENDDO
- frc_urb = frc_urb2d(I,J)
- lb_urb = lb_urb2d(I,J)
- check = 0
- if (I.eq.73.and.J.eq.125)THEN
- check = 1
- end if
- !
- ! Call urban
- CALL cal_mon_day(julian,julyr,jmonth,jday)
- CALL urban(LSOLAR_URB, & ! I
- num_roof_layers,num_wall_layers,num_road_layers, & ! C
- DZR,DZB,DZG, & ! C
- UTYPE_URB,TA_URB,QA_URB,UA_URB,U1_URB,V1_URB,SSG_URB, & ! I
- SSGD_URB,SSGQ_URB,LLG_URB,RAIN_URB,RHOO_URB, & ! I
- ZA_URB,DECLIN_URB,COSZ_URB,OMG_URB, & ! I
- XLAT_URB,DELT_URB,ZNT_URB, & ! I
- CHS_URB, CHS2_URB, & ! I
- TR_URB, TB_URB, TG_URB, TC_URB, QC_URB,UC_URB, & ! H
- TRL_URB,TBL_URB,TGL_URB, & ! H
- XXXR_URB, XXXB_URB, XXXG_URB, XXXC_URB, & ! H
- TS_URB,QS_URB,SH_URB,LH_URB,LH_KINEMATIC_URB, & ! O
- SW_URB,ALB_URB,LW_URB,G_URB,RN_URB,PSIM_URB,PSIH_URB, & ! O
- GZ1OZ0_URB, & !O
- CMR_URB, CHR_URB, CMC_URB, CHC_URB, &
- U10_URB, V10_URB, TH2_URB, Q2_URB, & ! O
- UST_URB,mh_urb, stdh_urb, lf_urb, lp_urb, & ! 0
- hgt_urb,frc_urb,lb_urb, check,CMCR_URB,TGR_URB, & ! H
- TGRL_URB,SMR_URB,CMGR_URB,CHGR_URB,jmonth, & ! H
- DRELR_URB,DRELB_URB, & ! H
- DRELG_URB,FLXHUMR_URB,FLXHUMB_URB,FLXHUMG_URB)
-
-#if 0
- IF(IPRINT) THEN
-
- print*, 'AFTER CALL URBAN'
- print*,'num_roof_layers',num_roof_layers, 'num_wall_layers', &
- num_wall_layers, &
- 'DZR',DZR,'DZB',DZB,'DZG',DZG,'UTYPE_URB',UTYPE_URB,'TA_URB', &
- TA_URB, &
- 'QA_URB',QA_URB,'UA_URB',UA_URB,'U1_URB',U1_URB,'V1_URB', &
- V1_URB, &
- 'SSG_URB',SSG_URB,'SSGD_URB',SSGD_URB,'SSGQ_URB',SSGQ_URB, &
- 'LLG_URB',LLG_URB,'RAIN_URB',RAIN_URB,'RHOO_URB',RHOO_URB, &
- 'ZA_URB',ZA_URB, 'DECLIN_URB',DECLIN_URB,'COSZ_URB',COSZ_URB,&
- 'OMG_URB',OMG_URB,'XLAT_URB',XLAT_URB,'DELT_URB',DELT_URB, &
- 'ZNT_URB',ZNT_URB,'TR_URB',TR_URB, 'TB_URB',TB_URB,'TG_URB',&
- TG_URB,'TC_URB',TC_URB,'QC_URB',QC_URB,'TRL_URB',TRL_URB, &
- 'TBL_URB',TBL_URB,'TGL_URB',TGL_URB,'XXXR_URB',XXXR_URB, &
- 'XXXB_URB',XXXB_URB,'XXXG_URB',XXXG_URB,'XXXC_URB',XXXC_URB,&
- 'TS_URB',TS_URB,'QS_URB',QS_URB,'SH_URB',SH_URB,'LH_URB', &
- LH_URB, 'LH_KINEMATIC_URB',LH_KINEMATIC_URB,'SW_URB',SW_URB,&
- 'ALB_URB',ALB_URB,'LW_URB',LW_URB,'G_URB',G_URB,'RN_URB', &
- RN_URB, 'PSIM_URB',PSIM_URB,'PSIH_URB',PSIH_URB, &
- 'U10_URB',U10_URB,'V10_URB',V10_URB,'TH2_URB',TH2_URB, &
- 'Q2_URB',Q2_URB,'CHS_URB',CHS_URB,'CHS2_URB',CHS2_URB
- endif
-#endif
-
- TS_URB2D(I,J) = TS_URB
-
- ALBEDO(I,J) = FRC_URB2D(I,J)*ALB_URB+(1-FRC_URB2D(I,J))*ALBEDOK ![-]
- HFX(I,J) = FRC_URB2D(I,J)*SH_URB+(1-FRC_URB2D(I,J))*SHEAT ![W/m/m]
- QFX(I,J) = FRC_URB2D(I,J)*LH_KINEMATIC_URB &
- + (1-FRC_URB2D(I,J))*ETA_KINEMATIC ![kg/m/m/s]
- LH(I,J) = FRC_URB2D(I,J)*LH_URB+(1-FRC_URB2D(I,J))*ETA ![W/m/m]
- GRDFLX(I,J) = FRC_URB2D(I,J)*G_URB+(1-FRC_URB2D(I,J))*SSOIL ![W/m/m]
- TSK(I,J) = FRC_URB2D(I,J)*TS_URB+(1-FRC_URB2D(I,J))*T1 ![K]
- Q1 = FRC_URB2D(I,J)*QS_URB+(1-FRC_URB2D(I,J))*Q1 ![-]
- ! Convert QSFC back to mixing ratio
- QSFC(I,J)= Q1/(1.0-Q1)
- UST(I,J)= FRC_URB2D(I,J)*UST_URB+(1-FRC_URB2D(I,J))*UST(I,J) ![m/s]
-
-#if 0
- IF(IPRINT)THEN
-
- print*, ' FRC_URB2D', FRC_URB2D, &
- 'ALB_URB',ALB_URB, 'ALBEDOK',ALBEDOK, &
- 'ALBEDO(I,J)', ALBEDO(I,J), &
- 'SH_URB',SH_URB,'SHEAT',SHEAT, 'HFX(I,J)',HFX(I,J), &
- 'LH_KINEMATIC_URB',LH_KINEMATIC_URB,'ETA_KINEMATIC', &
- ETA_KINEMATIC, 'QFX(I,J)',QFX(I,J), &
- 'LH_URB',LH_URB, 'ETA',ETA, 'LH(I,J)',LH(I,J), &
- 'G_URB',G_URB,'SSOIL',SSOIL,'GRDFLX(I,J)', GRDFLX(I,J),&
- 'TS_URB',TS_URB,'T1',T1,'TSK(I,J)',TSK(I,J), &
- 'QS_URB',QS_URB,'Q1',Q1,'QSFC(I,J)',QSFC(I,J)
- endif
-#endif
-
- ! Renew Urban State Varialbes
-
- TR_URB2D(I,J) = TR_URB
- TB_URB2D(I,J) = TB_URB
- TG_URB2D(I,J) = TG_URB
- TC_URB2D(I,J) = TC_URB
- QC_URB2D(I,J) = QC_URB
- UC_URB2D(I,J) = UC_URB
-
- DO K = 1,num_roof_layers
- TRL_URB3D(I,K,J) = TRL_URB(K)
- SMR_URB3D(I,K,J) = SMR_URB(K)
- TGRL_URB3D(I,K,J)= TGRL_URB(K)
- END DO
- DO K = 1,num_wall_layers
- TBL_URB3D(I,K,J) = TBL_URB(K)
- END DO
- DO K = 1,num_road_layers
- TGL_URB3D(I,K,J) = TGL_URB(K)
- END DO
-
- TGR_URB2D(I,J) =TGR_URB
- CMCR_URB2D(I,J)=CMCR_URB
- FLXHUMR_URB2D(I,J)=FLXHUMR_URB
- FLXHUMB_URB2D(I,J)=FLXHUMB_URB
- FLXHUMG_URB2D(I,J)=FLXHUMG_URB
- DRELR_URB2D(I,J) = DRELR_URB
- DRELB_URB2D(I,J) = DRELB_URB
- DRELG_URB2D(I,J) = DRELG_URB
-
- XXXR_URB2D(I,J) = XXXR_URB
- XXXB_URB2D(I,J) = XXXB_URB
- XXXG_URB2D(I,J) = XXXG_URB
- XXXC_URB2D(I,J) = XXXC_URB
-
- SH_URB2D(I,J) = SH_URB
- LH_URB2D(I,J) = LH_URB
- G_URB2D(I,J) = G_URB
- RN_URB2D(I,J) = RN_URB
- PSIM_URB2D(I,J) = PSIM_URB
- PSIH_URB2D(I,J) = PSIH_URB
- GZ1OZ0_URB2D(I,J)= GZ1OZ0_URB
- U10_URB2D(I,J) = U10_URB
- V10_URB2D(I,J) = V10_URB
- TH2_URB2D(I,J) = TH2_URB
- Q2_URB2D(I,J) = Q2_URB
- UST_URB2D(I,J) = UST_URB
- AKMS_URB2D(I,J) = KARMAN * UST_URB2D(I,J)/(GZ1OZ0_URB2D(I,J)-PSIM_URB2D(I,J))
- IF (PRESENT(CMR_SFCDIF)) THEN
- CMR_SFCDIF(I,J) = CMR_URB
- CHR_SFCDIF(I,J) = CHR_URB
- CMGR_SFCDIF(I,J) = CMGR_URB
- CHGR_SFCDIF(I,J) = CHGR_URB
- CMC_SFCDIF(I,J) = CMC_URB
- CHC_SFCDIF(I,J) = CHC_URB
- ENDIF
- END IF
-
- ENDIF ! end of UCM CALL if block
- !--------------------------------------
- ! Urban Part End - urban
- !--------------------------------------
-
- !*** DIAGNOSTICS
- SMSTAV(I,J)=SOILW
- SMSTOT(I,J)=SOILM*1000.
- DO NS=1,NSOIL
- SMCREL(I,NS,J)=SMAV(NS)
- ENDDO
-
- ! Convert the water unit into mm
- SFCRUNOFF(I,J)=SFCRUNOFF(I,J)+RUNOFF1*DT*1000.0
- UDRUNOFF(I,J)=UDRUNOFF(I,J)+RUNOFF2*DT*1000.0
- ! snow defined when fraction of frozen precip (FFROZP) > 0.5,
- IF(FFROZP.GT.0.5)THEN
- ACSNOW(I,J)=ACSNOW(I,J)+PRCP*DT
- ENDIF
- IF(SNOW(I,J).GT.0.)THEN
- ACSNOM(I,J)=ACSNOM(I,J)+SNOMLT*1000.
- ! accumulated snow-melt energy
- SNOPCX(I,J)=SNOPCX(I,J)-SNOMLT/FDTLIW
- ENDIF
-
- ENDIF ! endif of land-sea test
-
- ENDIF ! ENDIF FOR MOSAIC DANLI ! This corresponds to IF ((sf_surface_mosaic == 1) .AND. ((XLAND(I,J)-1.5).LT.0.) .AND. (XICE(I,J) < XICE_THRESHOLD) ) THEN
-
- ENDDO ILOOP ! of I loop
- ENDDO JLOOP ! of J loop
-
-!------------------------------------------------------
- END SUBROUTINE lsm_mosaic
-!------------------------------------------------------
-!===========================================================================
-!
-! subroutine lsm_mosaic_init: initialization of mosaic state variables
-!
-!===========================================================================
-
- SUBROUTINE lsm_mosaic_init(IVGTYP,ISWATER,ISURBAN,ISICE, XLAND, XICE,fractional_seaice, &
- TSK,TSLB,SMOIS,SH2O,SNOW,SNOWC,SNOWH,CANWAT, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte, restart, &
- landusef,landusef2,NLCAT,num_soil_layers &
- ,sf_surface_mosaic, mosaic_cat &
- ,mosaic_cat_index &
- ,TSK_mosaic,TSLB_mosaic &
- ,SMOIS_mosaic,SH2O_mosaic &
- ,CANWAT_mosaic,SNOW_mosaic &
- ,SNOWH_mosaic,SNOWC_mosaic &
- ,ALBEDO,ALBBCK, EMISS, EMBCK,Z0 & !danli
- ,ALBEDO_mosaic,ALBBCK_mosaic, EMISS_mosaic & !danli
- ,EMBCK_mosaic, ZNT_mosaic, Z0_mosaic & !danli
- ,TR_URB2D_mosaic,TB_URB2D_mosaic & !danli mosaic
- ,TG_URB2D_mosaic,TC_URB2D_mosaic & !danli mosaic
- ,QC_URB2D_mosaic & !danli mosaic
- ,TRL_URB3D_mosaic,TBL_URB3D_mosaic & !danli mosaic
- ,TGL_URB3D_mosaic & !danli mosaic
- ,SH_URB2D_mosaic,LH_URB2D_mosaic & !danli mosaic
- ,G_URB2D_mosaic,RN_URB2D_mosaic & !danli mosaic
- ,TS_URB2D_mosaic & !danli mosaic
- ,TS_RUL2D_mosaic & !danli mosaic
- )
-
- INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte
-
- INTEGER, INTENT(IN) :: NLCAT, num_soil_layers, ISWATER,ISURBAN, ISICE, fractional_seaice
-
- LOGICAL , INTENT(IN) :: restart
-
-! REAL, DIMENSION( num_soil_layers), INTENT(INOUT) :: ZS, DZS
-
- REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , &
- INTENT(IN) :: SMOIS, & !Total soil moisture
- SH2O, & !liquid soil moisture
- TSLB !STEMP
-
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(IN) :: SNOW, &
- SNOWH, &
- SNOWC, &
- CANWAT, &
- TSK, XICE, XLAND
-
- INTEGER, INTENT(IN) :: sf_surface_mosaic
- INTEGER, INTENT(IN) :: mosaic_cat
- INTEGER, DIMENSION( ims:ime, jms:jme ),INTENT(IN) :: IVGTYP
- REAL, DIMENSION( ims:ime, NLCAT, jms:jme ) , INTENT(IN):: LANDUSEF
- REAL, DIMENSION( ims:ime, NLCAT, jms:jme ) , INTENT(INOUT):: LANDUSEF2
-
- INTEGER, DIMENSION( ims:ime, NLCAT, jms:jme ), INTENT(INOUT) :: mosaic_cat_index
-
- REAL, DIMENSION( ims:ime, 1:mosaic_cat, jms:jme ) , OPTIONAL, INTENT(INOUT):: &
- TSK_mosaic, CANWAT_mosaic, SNOW_mosaic,SNOWH_mosaic, SNOWC_mosaic
- REAL, DIMENSION( ims:ime, 1:num_soil_layers*mosaic_cat, jms:jme ), OPTIONAL, INTENT(INOUT):: &
- TSLB_mosaic,SMOIS_mosaic,SH2O_mosaic
-
- REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(IN):: ALBEDO, ALBBCK, EMISS, EMBCK, Z0
- REAL, DIMENSION( ims:ime, 1:mosaic_cat, jms:jme ) , OPTIONAL, INTENT(INOUT):: &
- ALBEDO_mosaic,ALBBCK_mosaic, EMISS_mosaic, EMBCK_mosaic, ZNT_mosaic, Z0_mosaic
-
- REAL, DIMENSION( ims:ime, 1:mosaic_cat, jms:jme ) , OPTIONAL, INTENT(INOUT):: &
- TR_URB2D_mosaic, TB_URB2D_mosaic, TG_URB2D_mosaic, TC_URB2D_mosaic,QC_URB2D_mosaic, &
- SH_URB2D_mosaic,LH_URB2D_mosaic,G_URB2D_mosaic,RN_URB2D_mosaic,TS_URB2D_mosaic, TS_RUL2D_mosaic
-
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_soil_layers*mosaic_cat, jms:jme ), INTENT(INOUT) :: TRL_URB3D_mosaic
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_soil_layers*mosaic_cat, jms:jme ), INTENT(INOUT) :: TBL_URB3D_mosaic
- REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_soil_layers*mosaic_cat, jms:jme ), INTENT(INOUT) :: TGL_URB3D_mosaic
-
- INTEGER :: ij,i,j,mosaic_i,LastSwap,NumPairs,soil_k, Temp2,Temp5,Temp7, ICE,temp_index
- REAL :: Temp, Temp3,Temp4,Temp6,xice_threshold
- LOGICAL :: IPRINT
- CHARACTER(len=256) :: message_text
-
- IPRINT=.false.
-
- if ( fractional_seaice == 0 ) then
- xice_threshold = 0.5
- else if ( fractional_seaice == 1 ) then
- xice_threshold = 0.02
- endif
-
- IF(.not.restart)THEN
- !===========================================================================
- ! CHOOSE THE TILES
- !===========================================================================
-
- itf=min0(ite,ide-1)
- jtf=min0(jte,jde-1)
-
- ! simple test
-
- DO i = its,itf
- DO j = jts,jtf
- IF ((xland(i,j).LT. 1.5 ) .AND. (IVGTYP(i,j) .EQ. ISWATER)) THEN
- PRINT*, 'BEFORE MOSAIC_INIT'
- CALL wrf_message("BEFORE MOSAIC_INIT")
- WRITE(message_text,fmt='(a,2I6,2F8.2,2I6)') 'I,J,xland,xice,mosaic_cat_index,ivgtyp = ', &
- I,J,xland(i,j),xice(i,j),mosaic_cat_index(I,1,J),IVGTYP(i,j)
- CALL wrf_message(message_text)
- ENDIF
- ENDDO
- ENDDO
-
- DO i = its,itf
- DO j = jts,jtf
- DO mosaic_i=1,NLCAT
- LANDUSEF2(i,mosaic_i,j)=LANDUSEF(i,mosaic_i,j)
- mosaic_cat_index(i,mosaic_i,j)=mosaic_i
- ENDDO
- ENDDO
- ENDDO
-
- DO i = its,itf
- DO j = jts,jtf
-
- NumPairs=NLCAT-1
-
- DO
- IF (NumPairs == 0) EXIT
- LastSwap = 1
- DO mosaic_i=1, NumPairs
- IF(LANDUSEF2(i,mosaic_i, j) < LANDUSEF2(i,mosaic_i+1, j) ) THEN
- Temp = LANDUSEF2(i,mosaic_i, j)
- LANDUSEF2(i,mosaic_i, j)=LANDUSEF2(i,mosaic_i+1, j)
- LANDUSEF2(i,mosaic_i+1, j)=Temp
- LastSwap = mosaic_i
-
- Temp2 = mosaic_cat_index(i,mosaic_i,j)
- mosaic_cat_index(i,mosaic_i,j)=mosaic_cat_index(i,mosaic_i+1,j)
- mosaic_cat_index(i,mosaic_i+1,j)=Temp2
- ENDIF
- ENDDO
- NumPairs = LastSwap - 1
- ENDDO
-
- ENDDO
- ENDDO
-
- !===========================================================================
- ! For non-seaice grids, eliminate the seaice-tiles
- !===========================================================================
-
- DO i = its,itf
- DO j = jts,jtf
-
- IF (XLAND(I,J).LT.1.5) THEN
-
- ICE = 0
- IF( XICE(I,J).GE. XICE_THRESHOLD ) THEN
- WRITE (message_text,fmt='(a,2I5)') 'sea-ice at point, I and J = ', i,j
- CALL wrf_message(message_text)
- ICE = 1
- ENDIF
-
- IF (ICE == 1) Then ! sea-ice case , eliminate sea-ice if they are not the dominant ones
-
- IF (IVGTYP(i,j) == isice) THEN ! if this grid cell is dominanted by ice, then do nothing
-
- ELSE
-
- DO mosaic_i=2,mosaic_cat
- IF (mosaic_cat_index(i,mosaic_i,j) == isice ) THEN
- Temp4=LANDUSEF2(i,mosaic_i,j)
- Temp5=mosaic_cat_index(i,mosaic_i,j)
-
- LANDUSEF2(i,mosaic_i:NLCAT-1,j)=LANDUSEF2(i,mosaic_i+1:NLCAT,j)
- mosaic_cat_index(i,mosaic_i:NLCAT-1,j)=mosaic_cat_index(i,mosaic_i+1:NLCAT,j)
-
- LANDUSEF2(i,NLCAT,j)=Temp4
- mosaic_cat_index(i,NLCAT,j)=Temp5
- ENDIF
- ENDDO
-
- ENDIF ! for (IVGTYP(i,j) == isice )
-
- ELSEIF (ICE ==0) THEN
-
- IF ((mosaic_cat_index(I,1,J) .EQ. ISWATER)) THEN
-
- ! xland < 1.5 but the dominant land use category based on our calculation is water
-
- IF (IVGTYP(i,j) .EQ. ISWATER) THEN
-
- ! xland < 1.5 but the dominant land use category based on the geogrid calculation is water, this must be wrong
-
- CALL wrf_message("IN MOSAIC_INIT")
- WRITE(message_text,fmt='(a,3I6,2F8.2)') 'I,J,IVGTYP,XLAND,XICE = ',I,J,IVGTYP(I,J),xland(i,j),xice(i,j)
- CALL wrf_message(message_text)
- CALL wrf_message("xland < 1.5 but the dominant land use category based on our calculation is water."//&
- "In addition, the dominant land use category based on the geogrid calculation is water, this must be wrong")
-
- ENDIF ! for (IVGTYP(i,j) .EQ. ISWATER)
-
- IF (IVGTYP(i,j) .NE. ISWATER) THEN
-
- ! xland < 1.5, the dominant land use category based on our calculation is water, but based on the geogrid calculation is not water, which might be due to the inconsistence between land use data and land-sea mask
-
- Temp4=LANDUSEF2(i,1,j)
- Temp5=mosaic_cat_index(i,1,j)
-
- LANDUSEF2(i,1:NLCAT-1,j)=LANDUSEF2(i,2:NLCAT,j)
- mosaic_cat_index(i,1:NLCAT-1,j)=mosaic_cat_index(i,2:NLCAT,j)
-
- LANDUSEF2(i,NLCAT,j)=Temp4
- mosaic_cat_index(i,NLCAT,j)=Temp5
-
- CALL wrf_message("IN MOSAIC_INIT")
- WRITE(message_text,fmt='(a,3I6,2F8.2)') 'I,J,IVGTYP,XLAND,XICE = ',I,J,IVGTYP(I,J),xland(i,j),xice(i,j)
- CALL wrf_message(message_text)
- CALL wrf_message("xland < 1.5 but the dominant land use category based on our calculation is water."//&
- "this is fine as long as we change our calculation so that the dominant land use category is"//&
- "stwiched back to not water.")
- WRITE(message_text,fmt='(a,2I6)') 'land use category has been switched, before and after values are ', &
- temp5,mosaic_cat_index(i,1,j)
- CALL wrf_message(message_text)
- WRITE(message_text,fmt='(a,2I6)') 'new dominant and second dominant cat are ', mosaic_cat_index(i,1,j),mosaic_cat_index(i,2,j)
- CALL wrf_message(message_text)
-
- ENDIF ! for (IVGTYP(i,j) .NE. ISWATER)
-
- ELSE ! for (mosaic_cat_index(I,1,J) .EQ. ISWATER)
-
- DO mosaic_i=2,mosaic_cat
- IF (mosaic_cat_index(i,mosaic_i,j) == iswater ) THEN
- Temp4=LANDUSEF2(i,mosaic_i,j)
- Temp5=mosaic_cat_index(i,mosaic_i,j)
-
- LANDUSEF2(i,mosaic_i:NLCAT-1,j)=LANDUSEF2(i,mosaic_i+1:NLCAT,j)
- mosaic_cat_index(i,mosaic_i:NLCAT-1,j)=mosaic_cat_index(i,mosaic_i+1:NLCAT,j)
-
- LANDUSEF2(i,NLCAT,j)=Temp4
- mosaic_cat_index(i,NLCAT,j)=Temp5
- ENDIF
- ENDDO
-
- ENDIF ! for (mosaic_cat_index(I,1,J) .EQ. ISWATER)
-
- ENDIF ! for ICE == 1
-
- ELSE ! FOR (XLAND(I,J).LT.1.5)
-
- ICE = 0
-
- IF( XICE(I,J).GE. XICE_THRESHOLD ) THEN
- WRITE (message_text,fmt='(a,2I6)') 'sea-ice at water point, I and J = ', i,j
- CALL wrf_message(message_text)
- ICE = 1
- ENDIF
-
- IF ((mosaic_cat_index(I,1,J) .NE. ISWATER)) THEN
-
- ! xland > 1.5 and the dominant land use category based on our calculation is not water
-
- IF (IVGTYP(i,j) .NE. ISWATER) THEN
-
- ! xland > 1.5 but the dominant land use category based on the geogrid calculation is not water, this must be wrong
- CALL wrf_message("IN MOSAIC_INIT")
- WRITE(message_text,fmt='(a,3I6,2F8.2)') 'I,J,IVGTYP,XLAND,XICE = ',I,J,IVGTYP(I,J),xland(i,j),xice(i,j)
- CALL wrf_message(message_text)
- CALL wrf_message("xland > 1.5 but the dominant land use category based on our calculation is not water."// &
- "in addition, the dominant land use category based on the geogrid calculation is not water,"// &
- "this must be wrong.")
- ENDIF ! for (IVGTYP(i,j) .NE. ISWATER)
-
- IF (IVGTYP(i,j) .EQ. ISWATER) THEN
-
- ! xland > 1.5, the dominant land use category based on our calculation is not water, but based on the geogrid calculation is water, which might be due to the inconsistence between land use data and land-sea mask
-
- CALL wrf_message("IN MOSAIC_INIT")
- WRITE(message_text,fmt='(a,3I6,2F8.2)') 'I,J,IVGTYP,XLAND,XICE = ',I,J,IVGTYP(I,J),xland(i,j),xice(i,j)
- CALL wrf_message(message_text)
- CALL wrf_message("xland > 1.5 but the dominant land use category based on our calculation is not water."// &
- "however, the dominant land use category based on the geogrid calculation is water")
- CALL wrf_message("This is fine. We do not need to do anyting because in the noaddrv, "//&
- "we use xland as a criterion for whether using"// &
- "mosaic or not when xland > 1.5, no mosaic will be used anyway")
-
- ENDIF ! for (IVGTYP(i,j) .NE. ISWATER)
-
- ENDIF ! for (mosaic_cat_index(I,1,J) .NE. ISWATER)
-
- ENDIF ! FOR (XLAND(I,J).LT.1.5)
-
- ENDDO
- ENDDO
-
- !===========================================================================
- ! normalize
- !===========================================================================
-
- DO i = its,itf
- DO j = jts,jtf
-
- Temp6=0
-
- DO mosaic_i=1,mosaic_cat
- Temp6=Temp6+LANDUSEF2(i,mosaic_i,j)
- ENDDO
-
- if (Temp6 .LT. 1e-5) then
-
- Temp6 = 1e-5
- WRITE (message_text,fmt='(a,e8.1)') 'the total land surface fraction is less than ', temp6
- CALL wrf_message(message_text)
- WRITE (message_text,fmt='(a,2I6,4F8.2)') 'some landusef values at i,j are ', &
- i,j,landusef2(i,1,j),landusef2(i,2,j),landusef2(i,3,j),landusef2(i,4,j)
- CALL wrf_message(message_text)
- WRITE (message_text,fmt='(a,2I6,3I6)') 'some mosaic cat values at i,j are ', &
- i,j,mosaic_cat_index(i,1,j),mosaic_cat_index(i,2,j),mosaic_cat_index(i,3,j)
- CALL wrf_message(message_text)
-
- endif
-
- LANDUSEF2(i,1:mosaic_cat, j)=LANDUSEF2(i,1:mosaic_cat,j)*(1/Temp6)
-
- ENDDO
- ENDDO
-
- !===========================================================================
- ! initilize the variables
- !===========================================================================
-
- DO i = its,itf
- DO j = jts,jtf
-
- DO mosaic_i=1,mosaic_cat
-
- TSK_mosaic(i,mosaic_i,j)=TSK(i,j)
- CANWAT_mosaic(i,mosaic_i,j)=CANWAT(i,j)
- SNOW_mosaic(i,mosaic_i,j)=SNOW(i,j)
- SNOWH_mosaic(i,mosaic_i,j)=SNOWH(i,j)
- SNOWC_mosaic(i,mosaic_i,j)=SNOWC(i,j)
-
- ALBEDO_mosaic(i,mosaic_i,j)=ALBEDO(i,j)
- ALBBCK_mosaic(i,mosaic_i,j)=ALBBCK(i,j)
- EMISS_mosaic(i,mosaic_i,j)=EMISS(i,j)
- EMBCK_mosaic(i,mosaic_i,j)=EMBCK(i,j)
- ZNT_mosaic(i,mosaic_i,j)=Z0(i,j)
- Z0_mosaic(i,mosaic_i,j)=Z0(i,j)
-
- DO soil_k=1,num_soil_layers
-
- TSLB_mosaic(i,num_soil_layers*(mosaic_i-1)+soil_k,j)=TSLB(i,soil_k,j)
- SMOIS_mosaic(i,num_soil_layers*(mosaic_i-1)+soil_k,j)=SMOIS(i,soil_k,j)
- SH2O_mosaic(i,num_soil_layers*(mosaic_i-1)+soil_k,j)=SH2O(i,soil_k,j)
-
- ENDDO
-
- TR_URB2D_mosaic(i,mosaic_i,j)=TSK(i,j)
- TB_URB2D_mosaic(i,mosaic_i,j)=TSK(i,j)
- TG_URB2D_mosaic(i,mosaic_i,j)=TSK(i,j)
- TC_URB2D_mosaic(i,mosaic_i,j)=TSK(i,j)
- TS_URB2D_mosaic(i,mosaic_i,j)=TSK(i,j)
- TS_RUL2D_mosaic(i,mosaic_i,j)=TSK(i,j)
- QC_URB2D_mosaic(i,mosaic_i,j)=0.01
- SH_URB2D_mosaic(i,mosaic_i,j)=0
- LH_URB2D_mosaic(i,mosaic_i,j)=0
- G_URB2D_mosaic(i,mosaic_i,j)=0
- RN_URB2D_mosaic(i,mosaic_i,j)=0
-
- TRL_URB3D_mosaic(I,4*(mosaic_i-1)+1,J)=TSLB(I,1,J)+0.
- TRL_URB3D_mosaic(I,4*(mosaic_i-1)+2,J)=0.5*(TSLB(I,1,J)+TSLB(I,2,J))
- TRL_URB3D_mosaic(I,4*(mosaic_i-1)+3,J)=TSLB(I,2,J)+0.
- TRL_URB3D_mosaic(I,4*(mosaic_i-1)+4,J)=TSLB(I,2,J)+(TSLB(I,3,J)-TSLB(I,2,J))*0.29
-
- TBL_URB3D_mosaic(I,4*(mosaic_i-1)+1,J)=TSLB(I,1,J)+0.
- TBL_URB3D_mosaic(I,4*(mosaic_i-1)+2,J)=0.5*(TSLB(I,1,J)+TSLB(I,2,J))
- TBL_URB3D_mosaic(I,4*(mosaic_i-1)+3,J)=TSLB(I,2,J)+0.
- TBL_URB3D_mosaic(I,4*(mosaic_i-1)+4,J)=TSLB(I,2,J)+(TSLB(I,3,J)-TSLB(I,2,J))*0.29
-
- TGL_URB3D_mosaic(I,4*(mosaic_i-1)+1,J)=TSLB(I,1,J)
- TGL_URB3D_mosaic(I,4*(mosaic_i-1)+2,J)=TSLB(I,2,J)
- TGL_URB3D_mosaic(I,4*(mosaic_i-1)+3,J)=TSLB(I,3,J)
- TGL_URB3D_mosaic(I,4*(mosaic_i-1)+4,J)=TSLB(I,4,J)
-
- ENDDO
- ENDDO
- ENDDO
-
- ! simple test
-
- DO i = its,itf
- DO j = jts,jtf
-
- IF ((xland(i,j).LT. 1.5 ) .AND. (mosaic_cat_index(I,1,J) .EQ. ISWATER)) THEN
- CALL wrf_message("After MOSAIC_INIT")
- WRITE (message_text,fmt='(a,2I6,2F8.2,2I6)') 'weird xland,xice,mosaic_cat_index and ivgtyp at I,J = ', &
- i,j,xland(i,j),xice(i,j),mosaic_cat_index(I,1,J),IVGTYP(i,j)
- CALL wrf_message(message_text)
- ENDIF
-
- ENDDO
- ENDDO
-
- ENDIF ! for not restart
-
-!--------------------------------
- END SUBROUTINE lsm_mosaic_init
-!--------------------------------
-#endif
-
-END MODULE module_sf_noahdrv
diff --git a/UTIL/wrfcmaq_twoway_coupler/phys/module_twoway_ra_rrtmg_sw.F b/UTIL/wrfcmaq_twoway_coupler/phys/module_twoway_ra_rrtmg_sw.F
deleted file mode 100644
index 78da90c50c..0000000000
--- a/UTIL/wrfcmaq_twoway_coupler/phys/module_twoway_ra_rrtmg_sw.F
+++ /dev/null
@@ -1,1852 +0,0 @@
-! FSB REvised Mie calculations 02/09/2011
-
-MODULE module_twoway_ra_rrtmg_sw
-
-use module_model_constants, only : cp
-USE module_wrf_error
-#if (HWRF == 1)
-USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT,
-ETAMP_HWRF
-#else
-USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT
-#endif
-
-!USE module_dm
-
-use parrrsw, only : nbndsw, ngptsw, naerec
-use rrtmg_sw_init, only: rrtmg_sw_ini
-use rrtmg_sw_rad, only: rrtmg_sw
-use mcica_subcol_gen_sw, only: mcica_subcol_sw
-
-use module_ra_rrtmg_lw, only : inirad, o3data, relcalc, reicalc, retab
-
-private
-public :: RRTMG_SWRAD2
-
-contains
-
-!------------------------------------------------------------------
- SUBROUTINE RRTMG_SWRAD2( &
- rthratensw, &
- swupt, swuptc, swuptcln, swdnt, swdntc, swdntcln, &
- swupb, swupbc, swupbcln, swdnb, swdnbc, swdnbcln, &
-! swupflx, swupflxc, swdnflx, swdnflxc, &
- swcf, gsw, &
- xtime, gmt, xlat, xlong, &
- radt, degrad, declin, &
- coszr, julday, solcon, &
- albedo, t3d, t8w, tsk, &
- p3d, p8w, pi3d, rho3d, &
- dz8w, cldfra3d, lradius, iradius, &
- is_cammgmp_used, r, g, &
- re_cloud,re_ice,re_snow, &
- has_reqc,has_reqi,has_reqs, &
- icloud, warm_rain, &
- cldovrlp, & ! J. Henderson AER: cldovrlp namelist value
- f_ice_phy, f_rain_phy, &
- xland, xice, snow, &
- qv3d, qc3d, qr3d, &
- qi3d, qs3d, qg3d, &
- o3input, o33d, &
- aer_opt, aerod, no_src, &
- alswvisdir, alswvisdif, & !Zhenxin ssib alb comp (06/20/2011)
- alswnirdir, alswnirdif, & !Zhenxin ssib alb comp (06/20/2011)
- swvisdir, swvisdif, & !Zhenxin ssib swr comp (06/20/2011)
- swnirdir, swnirdif, & !Zhenxin ssib swi comp (06/20/2011)
- sf_surface_physics, & !Zhenxin
- f_qv, f_qc, f_qr, f_qi, f_qs, f_qg, &
- tauaer300,tauaer400,tauaer600,tauaer999, & ! czhao
- gaer300,gaer400,gaer600,gaer999, & ! czhao
- waer300,waer400,waer600,waer999, & ! czhao
- aer_ra_feedback, &
-!jdfcz progn,prescribe, &
- progn,calc_clean_atm_diag, &
- qndrop3d,f_qndrop, & !czhao
- mp_physics, & !wang 2014/12
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte, &
- swupflx, swupflxc, &
- swdnflx, swdnflxc, &
- tauaer3d_sw,ssaaer3d_sw,asyaer3d_sw, & ! jararias 2013/11
- swddir, swddni, swddif, & ! jararias 2013/08
- swdownc, swddnic, swddirc, & ! PAJ
- xcoszen,julian & ! jararias 2013/08
-! ** FSB Add aerosol input ffrom CMAQ
- ,nmode, & ! WRF-CMAQ twoway coupled model
- mass_ws_i, mass_ws_j, mass_ws_k, & ! WRF-CMAQ twoway coupled model
- mass_in_i, mass_in_j, mass_in_k, & ! WRF-CMAQ twoway coupled model
- mass_ec_i, mass_ec_j, mass_ec_k, & ! WRF-CMAQ twoway coupled model
- mass_ss_i, mass_ss_j, mass_ss_k, & ! WRF-CMAQ twoway coupled model
- mass_h2o_i, mass_h2o_j, mass_h2o_k, & ! WRF-CMAQ twoway coupled model
- dgn_i, dgn_j, dgn_k, & ! WRF-CMAQ twoway coupled model
- sig_i, sig_j, sig_k, & ! WRF-CMAQ twoway coupled model
- gtauxar_01, gtauxar_02, gtauxar_03, & ! WRF-CMAQ twoway coupled model
- gtauxar_04, gtauxar_05, & ! WRF-CMAQ twoway coupled model
- asy_fac_01, asy_fac_02, asy_fac_03, & ! WRF-CMAQ twoway coupled model
- asy_fac_04, asy_fac_05, & ! WRF-CMAQ twoway coupled model
- ssa_01, ssa_02, ssa_03, & ! WRF-CMAQ twoway coupled model
- ssa_04, ssa_05 & ! WRF-CMAQ twoway coupled model
- ,sw_zbbcddir & ! WRF-CMAQ twoway model
- ,sw_dirdflux, sw_difdflux & ! WRF-CMAQ twoway model
- )
-!------------------------------------------------------------------
- IMPLICIT NONE
-!------------------------------------------------------------------
- LOGICAL, INTENT(IN ) :: warm_rain
- LOGICAL, INTENT(IN ) :: is_CAMMGMP_used ! Added for CAM5 RRTMG<->CAMMGMP
-!
- INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte
-
- INTEGER, INTENT(IN ) :: ICLOUD
- INTEGER, INTENT(IN ) :: MP_PHYSICS
-!
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
- INTENT(IN ) :: dz8w, &
- t3d, &
- t8w, &
- p3d, &
- p8w, &
- pi3d, &
- rho3d
-
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
- INTENT(INOUT) :: RTHRATENSW
-
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(INOUT) :: GSW, &
- SWCF, &
- COSZR
-
- INTEGER, INTENT(IN ) :: JULDAY
- REAL, INTENT(IN ) :: RADT,DEGRAD, &
- XTIME,DECLIN,SOLCON,GMT
-
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- INTENT(IN ) :: XLAT, &
- XLONG, &
- XLAND, &
- XICE, &
- SNOW, &
- TSK, &
- ALBEDO
-!
-!!! ------------------- Zhenxin (2011-06/20) ------------------
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- OPTIONAL , &
- INTENT(IN) :: ALSWVISDIR, & ! ssib albedo of sw and lw
- ALSWVISDIF, &
- ALSWNIRDIR, &
- ALSWNIRDIF
-
- REAL, DIMENSION( ims:ime, jms:jme ) , &
- OPTIONAL , &
- INTENT(OUT) :: SWVISDIR, &
- SWVISDIF, &
- SWNIRDIR, &
- SWNIRDIF ! ssib sw dir and diff rad
- INTEGER, INTENT(IN) :: sf_surface_physics ! ssib para
-
-! ----------------------- end Zhenxin --------------------------
-!
-
-! ------------------------ jararias 2013/08/10 -----------------
- real, dimension(ims:ime,jms:jme), intent(out) :: &
- swddir, & ! All-sky broadband surface direct horiz irradiance
- swddni, & ! All-sky broadband surface direct normal irradiance
- swddif, & ! All-sky broadband surface diffuse irradiance
- swdownc, & ! Clear sky GHI
- swddnic, & ! Clear ski DNI
- swddirc ! Clear ski direct horizontal irradiance
-
- real, optional, intent(in) :: &
- julian ! julian day (1-366)
- real, dimension(ims:ime,jms:jme), intent(in) :: &
- xcoszen ! cosine of the solar zenith angle
- real, dimension(:,:,:,:), pointer :: tauaer3d_sw,ssaaer3d_sw,asyaer3d_sw
-! ------------------------ jararias end snippet -----------------
-
- REAL, INTENT(IN ) :: R,G
-!
-! Optional
-!
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
- OPTIONAL , &
- INTENT(IN ) :: &
- CLDFRA3D, &
- LRADIUS, &
- IRADIUS, &
- QV3D, &
- QC3D, &
- QR3D, &
- QI3D, &
- QS3D, &
- QG3D, &
- QNDROP3D
-
-!..Added by G. Thompson to couple cloud physics effective radii.
- REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN):: &
- RE_CLOUD, &
- RE_ICE, &
- RE_SNOW
- INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs
-
- real pi,third,relconst,lwpmin,rhoh2o
-
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
- OPTIONAL , &
- INTENT(IN ) :: &
- F_ICE_PHY, &
- F_RAIN_PHY
-
- LOGICAL, OPTIONAL, INTENT(IN) :: &
- F_QV,F_QC,F_QR,F_QI,F_QS,F_QG,F_QNDROP
-
-! Optional
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , &
- INTENT(IN ) :: tauaer300,tauaer400,tauaer600,tauaer999, & ! czhao
- gaer300,gaer400,gaer600,gaer999, & ! czhao
- waer300,waer400,waer600,waer999 ! czhao
-
- INTEGER, INTENT(IN ), OPTIONAL :: aer_ra_feedback
-!jdfcz INTEGER, INTENT(IN ), OPTIONAL :: progn,prescribe
- INTEGER, INTENT(IN ), OPTIONAL :: progn
- INTEGER, INTENT(IN ) :: calc_clean_atm_diag
-
-! Ozone
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
- OPTIONAL , &
- INTENT(IN ) :: O33D
- INTEGER, OPTIONAL, INTENT(IN ) :: o3input
-! EC aerosol: no_src = naerec = 6
- INTEGER, INTENT(IN ) :: no_src
- REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 1:no_src ) , &
- OPTIONAL , &
- INTENT(IN ) :: aerod
- INTEGER, OPTIONAL, INTENT(IN ) :: aer_opt
-
- !wavelength corresponding to wavenum1 and wavenum2 (cm-1)
- real, save :: wavemin(nbndsw) ! Min wavelength (um) of 14 intervals
- data wavemin /3.077,2.500,2.150,1.942,1.626,1.299, &
- 1.242,0.778,0.625,0.442,0.345,0.263,0.200,3.846/
- real, save :: wavemax(nbndsw) ! Max wavelength (um) of interval
- data wavemax/3.846,3.077,2.500,2.150,1.942,1.626, &
- 1.299,1.242,0.778,0.625,0.442,0.345,0.263,12.195/
- real wavemid(nbndsw) ! Mid wavelength (um) of interval
- real, parameter :: thresh=1.e-9
- real ang,slope
- character(len=200) :: msg
-
-! Top of atmosphere and surface shortwave fluxes (W m-2)
- REAL, DIMENSION( ims:ime, jms:jme ), &
- OPTIONAL, INTENT(INOUT) :: &
- SWUPT,SWUPTC,SWUPTCLN,SWDNT,SWDNTC,SWDNTCLN, &
- SWUPB,SWUPBC,SWUPBCLN,SWDNB,SWDNBC,SWDNBCLN
-
-! Layer shortwave fluxes (including extra layer above model top)
-! Vertical ordering is from bottom to top (W m-2)
- REAL, DIMENSION( ims:ime, kms:kme+2, jms:jme ), &
- OPTIONAL, INTENT(OUT) :: &
- SWUPFLX,SWUPFLXC, &
- SWDNFLX,SWDNFLXC
-
-! =s= WRF-CMAQ twoway coupled model
-! ** FSB items needed for new aerosol code from CMAQ
- integer, intent(in) :: nmode ! number of log-normal modes
-
-! the following mass cocentrations are in [ ug/m**3]
-! mass_ws_* - water soluble species
-! mass_in_* _ isoluble species
-! mass_ec_* - elemental carbon
-! mass_h2o_* - aerosol water
-! mass_ss_* - sea salt
-! dgn_* - geometric mean diameter of each mode [ m ]
-! sig_* _ geometric standard deviation of each mode
-
- real, dimension(ims:ime, kms:kme, jms:jme), intent(in) :: &
- mass_ws_i, mass_ws_j, mass_ws_k, &
- mass_in_i, mass_in_j, mass_in_k, &
- mass_ec_i, mass_ec_j, mass_ec_k, &
- mass_ss_i, mass_ss_j, mass_ss_k, &
- mass_h2o_i, mass_h2o_j, mass_h2o_k, &
- dgn_i, dgn_j, dgn_k, &
- sig_i, sig_j, sig_k
-
- real, dimension(ims:ime, kms:kme, jms:jme), intent(out) :: gtauxar_01, &
- gtauxar_02, &
- gtauxar_03, &
- gtauxar_04, &
- gtauxar_05, &
- asy_fac_01, &
- asy_fac_02, &
- asy_fac_03, &
- asy_fac_04, &
- asy_fac_05, &
- ssa_01, &
- ssa_02, &
- ssa_03, &
- ssa_04, &
- ssa_05
-
- REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: sw_zbbcddir, &
- sw_dirdflux, &
- sw_difdflux
-
-! =e= WRF-CMAQ twoway coupled model
-
-! LOCAL VARS
-
- REAL, DIMENSION( kts:kte+1 ) :: Pw1D, &
- Tw1D
-
- REAL, DIMENSION( kts:kte ) :: TTEN1D, &
- CLDFRA1D, &
- DZ1D, &
- P1D, &
- T1D, &
- QV1D, &
- QC1D, &
- QR1D, &
- QI1D, &
- RHO1D, &
- QS1D, &
- QG1D, &
- O31D, &
- qndrop1d
-
-!BSF: From eq. (5) on p. 2434 in McFarquhar & Heymsfield (1996)
- real, parameter :: re_50C=1250.0/9.917, re_40C=1250.0/9.337, &
- re_30C=1250.0/9.208, re_20C=1250.0/9.387
-
-! Added local arrays for RRTMG
- integer :: ncol, &
- nlay, &
- icld, &
- cldovrlp, & ! J. Henderson AER
- inflgsw, &
- iceflgsw, &
- liqflgsw
-! Dimension with extra layer from model top to TOA
- real, dimension( 1, kts:kte+2 ) :: plev, &
- tlev
- real, dimension( 1, kts:kte+1 ) :: play, &
- tlay, &
- h2ovmr, &
- o3vmr, &
- co2vmr, &
- o2vmr, &
- ch4vmr, &
- n2ovmr
- real, dimension( kts:kte+1 ) :: o3mmr
-! mji - Add height of each layer for exponential-random cloud overlap
-! This will be derived below from the dz in each layer
- real, dimension( 1, kts:kte+1 ) :: hgt
- real :: dzsum
-! Surface albedo (for UV/visible and near-IR spectral regions,
-! and for direct and diffuse radiation)
- real, dimension( 1 ) :: asdir, &
- asdif, &
- aldir, &
- aldif
-! Dimension with extra layer from model top to TOA,
-! though no clouds are allowed in extra layer
- real, dimension( 1, kts:kte+1 ) :: clwpth, &
- ciwpth, &
- cswpth, &
- rel, &
- rei, &
- res, &
- cldfrac, &
- relqmcl, &
- reicmcl, &
- resnmcl
- real, dimension( nbndsw, 1, kts:kte+1 ) :: taucld, &
- ssacld, &
- asmcld, &
- fsfcld
- real, dimension( ngptsw, 1, kts:kte+1 ) :: cldfmcl, &
- clwpmcl, &
- ciwpmcl, &
- cswpmcl, &
- taucmcl, &
- ssacmcl, &
- asmcmcl, &
- fsfcmcl
- real, dimension( 1, kts:kte+1, nbndsw ) :: tauaer, &
- ssaaer, &
- asmaer
- real, dimension( 1, kts:kte+1, naerec ) :: ecaer
-
-! Output arrays contain extra layer from model top to TOA
- real, dimension( 1, kts:kte+2 ) :: swuflx, &
- swdflx, &
- swuflxc, &
- swdflxc, &
- swuflxcln, &
- swdflxcln, &
- sibvisdir, & ! Zhenxin 2011-06-20
- sibvisdif, &
- sibnirdir, &
- sibnirdif ! Zhenxin 2011-06-20
-
- real, dimension( 1, kts:kte+2 ) :: swdkdir, & ! jararias, 2013/08/10
- swdkdif, & ! jararias, 2013/08/10
- swdkdirc ! PAJ
-
- real, dimension( 1, kts:kte+1 ) :: swhr, &
- swhrc
-
- real, dimension ( 1 ) :: tsfc, &
- ps, &
- coszen
- real :: ro, &
- dz, &
- adjes, &
- scon, &
- snow_mass_factor
- integer :: dyofyr
-
- integer:: idx_rei
- real:: corr
-
-! Set trace gas volume mixing ratios, 2005 values, IPCC (2007)
-! carbon dioxide (379 ppmv)
- real :: co2
- data co2 / 379.e-6 /
-! methane (1774 ppbv)
- real :: ch4
- data ch4 / 1774.e-9 /
-! nitrous oxide (319 ppbv)
- real :: n2o
- data n2o / 319.e-9 /
-! Set oxygen volume mixing ratio (for o2mmr=0.23143)
- real :: o2
- data o2 / 0.209488 /
-
- integer :: iplon, irng, permuteseed
- integer :: nb
-
-! For old lw cloud property specification
-! Cloud and precipitation absorption coefficients
-! real :: abcw,abice,abrn,absn
-! data abcw /0.144/
-! data abice /0.0735/
-! data abrn /0.330e-3/
-! data absn /2.34e-3/
-
-! Molecular weights and ratios for converting mmr to vmr units
-! real :: amd ! Effective molecular weight of dry air (g/mol)
-! real :: amw ! Molecular weight of water vapor (g/mol)
-! real :: amo ! Molecular weight of ozone (g/mol)
-! real :: amo2 ! Molecular weight of oxygen (g/mol)
-! Atomic weights for conversion from mass to volume mixing ratios
-! data amd / 28.9660 /
-! data amw / 18.0160 /
-! data amo / 47.9998 /
-! data amo2 / 31.9999 /
-
- real :: amdw ! Molecular weight of dry air / water vapor
- real :: amdo ! Molecular weight of dry air / ozone
- real :: amdo2 ! Molecular weight of dry air / oxygen
- data amdw / 1.607793 /
- data amdo / 0.603461 /
- data amdo2 / 0.905190 /
-
-!!
- real, dimension(1, 1:kte-kts+1 ) :: pdel ! Layer pressure thickness (mb)
-
- real, dimension(1, 1:kte-kts+1) :: cicewp, & ! in-cloud cloud ice water path
- cliqwp, & ! in-cloud cloud liquid water path
- csnowp, & ! in-cloud snow water path
- reliq, & ! effective drop radius (microns)
- reice ! ice effective drop size (microns)
- real, dimension(1, 1:kte-kts+1):: recloud1d, &
- reice1d, &
- resnow1d
- real :: gliqwp, gicewp, gsnowp, gravmks, tem1,tem2,tem3
-
-!
-! REAL :: TSFC,GLW0,OLR0,EMISS0,FP
- REAL :: FP
-
-! real, dimension(1:ite-its+1 ) :: clat ! latitude in radians for columns
- real :: coszrs ! Cosine of solar zenith angle for present latitude
- logical :: dorrsw ! Flag to allow shortwave calculation
-
- real, dimension (1) :: landfrac, landm, snowh, icefrac
-
- integer :: pcols, pver
-
- INTEGER :: i,j,K, na
- LOGICAL :: predicate
-
- REAL :: da, eot ! jararias, 14/08/2013
-
-! =s= WRF-CMAQ twoway model
-! fsb local variables for setting tauaer, sssaaer, asmaer
-! FSB local variabble for C0AQ aerosols
- REAL, DIMENSION (nmode) :: INMASS_ws, INMASS_in, &
- INMASS_ec, INMASS_ss, INMASS_h2o, INDGN, INSIG
- REAL xtauaer, waer, gaer
- REAL delta_z ! local layer thickness
-
- INTEGER modes
-
- character (len = 50) :: mystr
-! =e= WRF-CMAQ twoway model
-
-!------------------------------------------------------------------
-#if ( WRF_CHEM == 1 )
- IF ( aer_ra_feedback == 1) then
- IF ( .NOT. &
- ( PRESENT(tauaer300) .AND. &
- PRESENT(tauaer400) .AND. &
- PRESENT(tauaer600) .AND. &
- PRESENT(tauaer999) .AND. &
- PRESENT(gaer300) .AND. &
- PRESENT(gaer400) .AND. &
- PRESENT(gaer600) .AND. &
- PRESENT(gaer999) .AND. &
- PRESENT(waer300) .AND. &
- PRESENT(waer400) .AND. &
- PRESENT(waer600) .AND. &
- PRESENT(waer999) ) ) THEN
- CALL wrf_error_fatal &
- ('Warning: missing fields required for aerosol radiation' )
- ENDIF
- ENDIF
-#endif
-
-!-----CALCULATE SHORT WAVE RADIATION
-!
-! All fields are ordered vertically from bottom to top
-! Pressures are in mb
-
-! latitude loop
- j_loop: do j = jts,jte
-
-! longitude loop
- i_loop: do i = its,ite
- rho1d(kts:kte)=rho3d(i,kts:kte,j) ! BUG FIX (SGT): this was uninitialized
-!
-! Do shortwave by default, deactivate below if sun below horizon
- dorrsw = .true.
-
-! Cosine solar zenith angle for current time step
-!
- ! jararias, 14/08/2013
- coszr(i,j)=xcoszen(i,j)
- coszrs=xcoszen(i,j)
-
-! Set flag to prevent shortwave calculation when sun below horizon
- if (coszrs.le.0.0) dorrsw = .false.
-! Perform shortwave calculation if sun above horizon
- if (dorrsw) then
-
- do k=kts,kte+1
- Pw1D(K) = p8w(I,K,J)/100.
- Tw1D(K) = t8w(I,K,J)
- enddo
-
- DO K=kts,kte
- QV1D(K)=0.
- QC1D(K)=0.
- QR1D(K)=0.
- QI1D(K)=0.
- QS1D(K)=0.
- CLDFRA1D(k)=0.
- QNDROP1D(k)=0.
- ENDDO
-
- DO K=kts,kte
- QV1D(K)=QV3D(I,K,J)
- QV1D(K)=max(0.,QV1D(K))
- ENDDO
-
- IF (PRESENT(O33D)) THEN
- DO K=kts,kte
- O31D(K)=O33D(I,K,J)
- ENDDO
- ELSE
- DO K=kts,kte
- O31D(K)=0.0
- ENDDO
- ENDIF
-
- DO K=kts,kte
- TTEN1D(K)=0.
- T1D(K)=t3d(I,K,J)
- P1D(K)=p3d(I,K,J)/100.
- DZ1D(K)=dz8w(I,K,J)
- ENDDO
-
-! moist variables
-
- IF (ICLOUD .ne. 0) THEN
- IF ( PRESENT( CLDFRA3D ) ) THEN
- DO K=kts,kte
- CLDFRA1D(k)=CLDFRA3D(I,K,J)
- ENDDO
- ENDIF
-
- IF (PRESENT(F_QC) .AND. PRESENT(QC3D)) THEN
- IF ( F_QC) THEN
- DO K=kts,kte
- QC1D(K)=QC3D(I,K,J)
- QC1D(K)=max(0.,QC1D(K))
- ENDDO
- ENDIF
- ENDIF
-
- IF (PRESENT(F_QR) .AND. PRESENT(QR3D)) THEN
- IF ( F_QR) THEN
- DO K=kts,kte
- QR1D(K)=QR3D(I,K,J)
- QR1D(K)=max(0.,QR1D(K))
- ENDDO
- ENDIF
- ENDIF
-
- IF ( PRESENT(F_QNDROP).AND.PRESENT(QNDROP3D)) THEN
- IF (F_QNDROP) THEN
- DO K=kts,kte
- qndrop1d(K)=qndrop3d(I,K,J)
- ENDDO
- ENDIF
- ENDIF
-
-! This logic is tortured because cannot test F_QI unless
-! it is present, and order of evaluation of expressions
-! is not specified in Fortran
-
- IF ( PRESENT ( F_QI ) ) THEN
- predicate = F_QI
- ELSE
- predicate = .FALSE.
- ENDIF
-
-! For MP option 3
- IF (.NOT. predicate .and. .not. warm_rain) THEN
- DO K=kts,kte
- IF (T1D(K) .lt. 273.15) THEN
- QI1D(K)=QC1D(K)
- QS1D(K)=QR1D(K)
- QC1D(K)=0.
- QR1D(K)=0.
- ENDIF
- ENDDO
- ENDIF
-
- IF (PRESENT(F_QI) .AND. PRESENT(QI3D)) THEN
- IF (F_QI) THEN
- DO K=kts,kte
- QI1D(K)=QI3D(I,K,J)
- QI1D(K)=max(0.,QI1D(K))
- ENDDO
- ENDIF
- ENDIF
-
- IF (PRESENT(F_QS) .AND. PRESENT(QS3D)) THEN
- IF (F_QS) THEN
- DO K=kts,kte
- QS1D(K)=QS3D(I,K,J)
- QS1D(K)=max(0.,QS1D(K))
- ENDDO
- ENDIF
- ENDIF
-
- IF (PRESENT(F_QG) .AND. PRESENT(QG3D)) THEN
- IF (F_QG) THEN
- DO K=kts,kte
- QG1D(K)=QG3D(I,K,J)
- QG1D(K)=max(0.,QG1D(K))
- ENDDO
- ENDIF
- ENDIF
-
-! mji - For MP option 5
- IF ( PRESENT(F_QI) .and. PRESENT(F_QC) .and. PRESENT(F_QS) .and. PRESENT(F_ICE_PHY) ) THEN
- IF ( F_QC .and. .not. F_QI .and. F_QS ) THEN
- DO K=kts,kte
- qi1d(k) = 0.1*qs3d(i,k,j)
- qs1d(k) = 0.9*qs3d(i,k,j)
- qc1d(k) = qc3d(i,k,j)
- qi1d(k) = max(0.,qi1d(k))
- qc1d(k) = max(0.,qc1d(k))
- ENDDO
- ENDIF
- ENDIF
-
- ENDIF
-! For mp option=5 or 85 (new Ferrier- Aligo or called fer_hires
-! scheme), QI3D saves all frozen water (ice+snow)
-#if (HWRF == 1)
- IF ( mp_physics == FER_MP_HIRES .OR. &
- mp_physics == FER_MP_HIRES_ADVECT .OR. &
- mp_physics == ETAMP_HWRF ) THEN
-#else
- IF ( mp_physics == FER_MP_HIRES .OR. &
- mp_physics == FER_MP_HIRES_ADVECT) THEN
-#endif
- DO K=kts,kte
- qi1d(k) = qi3d(i,k,j)
- qs1d(k) = 0.0
- qc1d(k) = qc3d(i,k,j)
- qi1d(k) = max(0.,qi1d(k))
- qc1d(k) = max(0.,qc1d(k))
- ENDDO
- ENDIF
-!
-! EMISS0=EMISS(I,J)
-! GLW0=0.
-! OLR0=0.
-! TSFC=TSK(I,J)
- DO K=kts,kte
- QV1D(K)=AMAX1(QV1D(K),1.E-12)
- ENDDO
-
-! Set up input for shortwave
- ncol = 1
-! Add extra layer from top of model to top of atmosphere
- nlay = (kte - kts + 1) + 1
-
-! Select cloud overlap assumption (1 = random, 2 = maximum-random, 3 = maximum, 4 = exponential, 5 = exponential-random
- icld=cldovrlp ! J. Henderson AER assign namelist variable cldovrlp to existing icld
-
-! Select cloud liquid and ice optics parameterization options
-! For passing in cloud optical properties directly:
-! inflgsw = 0
-! iceflgsw = 0
-! liqflgsw = 0
-! For passing in cloud physical properties; cloud optics parameterized in RRTMG:
- inflgsw = 2
- iceflgsw = 3
- liqflgsw = 1
-
-!Mukul change the flags here with reference to the new effective cloud/ice/snow radius
- IF (ICLOUD .ne. 0) THEN
- IF ( has_reqc .ne. 0) THEN
- inflgsw = 3
- DO K=kts,kte
- recloud1D(ncol,K) = MAX(2.5, re_cloud(I,K,J)*1.E6)
- if (recloud1D(ncol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. &
- & .AND. (XLAND(I,J)-1.5).GT.0.) then !--- Ocean
- recloud1D(ncol,K) = 10.5
- elseif (recloud1D(ncol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. &
- & .AND. (XLAND(I,J)-1.5).LT.0.) then !--- Land
- recloud1D(ncol,K) = 7.5
- endif
- ENDDO
- ELSE
- DO K=kts,kte
-#if (EM_CORE==1)
- recloud1D(ncol,K) = 5.0
-#else
- recloud1D(ncol,K) = 10.0 ! was 5.0
-#endif
- ENDDO
- ENDIF
-
- IF ( has_reqi .ne. 0) THEN
- inflgsw = 4
- iceflgsw = 4
- DO K=kts,kte
- reice1D(ncol,K) = MAX(5., re_ice(I,K,J)*1.E6)
- if (reice1D(ncol,K).LE.5..AND.cldfra3d(i,k,j).gt.0.) then
- idx_rei = int(t3d(i,k,j)-179.)
- idx_rei = min(max(idx_rei,1),75)
- corr = t3d(i,k,j) - int(t3d(i,k,j))
- reice1D(ncol,K) = retab(idx_rei)*(1.-corr) + &
- & retab(idx_rei+1)*corr
- reice1D(ncol,K) = MAX(reice1D(ncol,K), 5.0)
- endif
- ENDDO
- ELSE
- DO K=kts,kte
- reice1D(ncol,K) = 10.
- ENDDO
- ENDIF
-
- IF ( has_reqs .ne. 0) THEN
- inflgsw = 5
- iceflgsw = 5
- DO K=kts,kte
- resnow1D(ncol,K) = MAX(10., re_snow(I,K,J)*1.E6)
- ENDDO
- ELSE
- DO K=kts,kte
-#if (EM_CORE==1)
- resnow1D(ncol,K) = 10.0
-#else
- tem2 = 25.0 !- was 10.0
- tem3=1.e3*rho1d(k)*qi1d(k) !- IWC (g m^-3)
- if (tem3>thresh) then !- Only when IWC>1.e-9 g m^-3
- tem1=t1d(k)-273.15
- if (tem1 < -50.0) then
- tem2 = re_50C*tem3**0.109
- elseif (tem1 < -40.0) then
- tem2 = re_40C*tem3**0.08
- elseif (tem1 < -30.0) then
- tem2 = re_30C*tem3**0.055
- else
- tem2 = re_20C*tem3**0.031
- endif
- tem2 = max(25.,tem2)
- endif
- reice1D(ncol,K) = min(tem2, 135.72) !- 1.0315*reice <= 140 microns
-#endif
- ENDDO
- ENDIF
-
-! special case for P3 microphysics
-! put ice into snow category for optics, then set ice to zero
- IF ( has_reqs .eq. 0 .and. has_reqi .ne. 0 .and. has_reqc .ne. 0) THEN
- inflgsw = 5
- iceflgsw = 5
- DO K=kts,kte
- resnow1D(ncol,K) = MAX(10., re_ice(I,K,J)*1.E6)
- QS1D(K)=QI3D(I,K,J)
- QI1D(K)=0.
- reice1D(ncol,K)=10.
- END DO
-
- END IF
-
- ENDIF
-
-! Set cosine of solar zenith angle
- coszen(ncol) = coszrs
-! Set solar constant
- scon = solcon
-! For Earth/Sun distance adjustment in RRTMG
-! dyofyr = julday
-! adjes = 0.0
-! For WRF, solar constant is already provided with eccentricity adjustment,
-! so do not do this in RRTMG
- dyofyr = 0
- adjes = 1.0
-
-! Layer indexing goes bottom to top here for all fields.
-! Water vapor and ozone are converted from mmr to vmr.
-! Pressures are in units of mb here.
- plev(ncol,1) = pw1d(1)
- tlev(ncol,1) = tw1d(1)
- tsfc(ncol) = tsk(i,j)
- do k = kts, kte
- play(ncol,k) = p1d(k)
- plev(ncol,k+1) = pw1d(k+1)
- pdel(ncol,k) = plev(ncol,k) - plev(ncol,k+1)
- tlay(ncol,k) = t1d(k)
- tlev(ncol,k+1) = tw1d(k+1)
- h2ovmr(ncol,k) = qv1d(k) * amdw
- co2vmr(ncol,k) = co2
- o2vmr(ncol,k) = o2
- ch4vmr(ncol,k) = ch4
- n2ovmr(ncol,k) = n2o
- enddo
-
-! mji - Derive height of each layer mid-point from layer thickness.
-! Needed for exponential (icld=4) and exponential-random overlap option (icld=5) only.
- dzsum = 0.0
- do k = kts, kte
- dz = dz1d(k)
- hgt(ncol,k) = dzsum + 0.5*dz
- dzsum = dzsum + dz
- enddo
-
-! Define profile values for extra layer from model top to top of atmosphere.
-! The top layer temperature for all gridpoints is set to the top layer-1
-! temperature plus a constant (0 K) that represents an isothermal layer
-! above ptop. Top layer interface temperatures are linearly interpolated
-! from the layer temperatures.
-
- play(ncol,kte+1) = 0.5 * plev(ncol,kte+1)
- tlay(ncol,kte+1) = tlev(ncol,kte+1) + 0.0
- plev(ncol,kte+2) = 1.0e-5
- tlev(ncol,kte+2) = tlev(ncol,kte+1) + 0.0
- tlev(ncol,kte+2) = tlev(ncol,kte+1) + 0.0
- h2ovmr(ncol,kte+1) = h2ovmr(ncol,kte)
- co2vmr(ncol,kte+1) = co2vmr(ncol,kte)
- o2vmr(ncol,kte+1) = o2vmr(ncol,kte)
- ch4vmr(ncol,kte+1) = ch4vmr(ncol,kte)
- n2ovmr(ncol,kte+1) = n2ovmr(ncol,kte)
-
-! mji - Fill in height array above model top to top of atmosphere using
-! dz from model top layer for completeness, though this information is not
-! likely to be used by the exponential-random cloud overlap method.
- hgt(ncol,kte+1) = dzsum + 0.5*dz
-
-! Get ozone profile including amount in extra layer above model top
- call inirad (o3mmr,plev,kts,kte)
-
- if(present(o33d)) then
- do k = kts, kte+1
- o3vmr(ncol,k) = o3mmr(k) * amdo
- IF ( PRESENT( O33D ) ) THEN
- if(o3input .eq. 2)then
- if(k.le.kte)then
- o3vmr(ncol,k) = o31d(k)
- else
-! apply shifted climatology profile above model top
- o3vmr(ncol,k) = o31d(kte) - o3mmr(kte)*amdo + o3mmr(k)*amdo
- if(o3vmr(ncol,k) .le. 0.)o3vmr(ncol,k) = o3mmr(k)*amdo
- endif
- endif
- ENDIF
- enddo
- else
- do k = kts, kte+1
- o3vmr(ncol,k) = o3mmr(k) * amdo
- enddo
- endif
-
-! Set surface albedo for direct and diffuse radiation in UV/visible and
-! near-IR spectral regions
-! -------------- Zhenxin 2011-06-20 ----------- !
-
-! ------- 1. Commented by Zhenxin 2011-06-20 for SSiB coupling modified ---- !
-! asdir(ncol) = albedo(i,j)
-! asdif(ncol) = albedo(i,j)
-! aldir(ncol) = albedo(i,j)
-! aldif(ncol) = albedo(i,j)
-! ------- End of Comments ------ !
-
-! ------- 2. New Addiation ------ !
- IF ( sf_surface_physics .eq. 8 .AND. XLAND(i,j) .LT. 1.5) THEN
- asdir(ncol) = ALSWVISDIR(I,J)
- asdif(ncol) = ALSWVISDIF(I,J)
- aldir(ncol) = ALSWNIRDIR(I,J)
- aldif(ncol) = ALSWNIRDIF(I,J)
- ELSE
- asdir(ncol) = albedo(i,j)
- asdif(ncol) = albedo(i,j)
- aldir(ncol) = albedo(i,j)
- aldif(ncol) = albedo(i,j)
- ENDIF
-
-! ---------- End of Addiation ------!
-! ---------- End of fds_Zhenxin 2011-06-20 --------------!
-
-! Define cloud optical properties for radiation (inflgsw = 0)
-! This option is not currently active
-! Cloud and precipitation paths in g/m2
-! qi=0 if no ice phase
-! qs=0 if no ice phase
- if (inflgsw .eq. 0) then
-
-! Set cloud fraction and cloud optical properties here; not yet active
- do k = kts, kte
- cldfrac(ncol,k) = cldfra1d(k)
- do nb = 1, nbndsw
- taucld(nb,ncol,k) = 0.0
- ssacld(nb,ncol,k) = 1.0
- asmcld(nb,ncol,k) = 0.0
- fsfcld(nb,ncol,k) = 0.0
- enddo
- enddo
-
-! Zero out cloud physical property arrays; not used when passing optical properties
-! into radiation
- do k = kts, kte
- clwpth(ncol,k) = 0.0
- ciwpth(ncol,k) = 0.0
- rel(ncol,k) = 10.0
- rei(ncol,k) = 10.
- enddo
- endif
-
-! Define cloud physical properties for radiation (inflgsw = 1 or 2)
-! Cloud fraction
-! Set cloud arrays if passing cloud physical properties into radiation
- if (inflgsw .gt. 0) then
- do k = kts, kte
- cldfrac(ncol,k) = cldfra1d(k)
- enddo
-
-! Compute cloud water/ice paths and particle sizes for input to radiation (CAM method)
- pcols = ncol
- pver = kte - kts + 1
- gravmks = g
- landfrac(ncol) = 2.-XLAND(I,J)
- landm(ncol) = landfrac(ncol)
- snowh(ncol) = 0.001*SNOW(I,J)
- icefrac(ncol) = XICE(I,J)
-
-! From module_ra_cam: Convert liquid and ice mixing ratios to water paths;
-! pdel is in mb here; convert back to Pa (*100.)
-! Water paths are in units of g/m2
-! snow added as ice cloud (JD 091022)
- do k = kts, kte
- gicewp = (qi1d(k)+qs1d(k)) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path.
- gliqwp = qc1d(k) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box liquid water path.
- cicewp(ncol,k) = gicewp / max(0.01,cldfrac(ncol,k)) ! In-cloud ice water path.
- cliqwp(ncol,k) = gliqwp / max(0.01,cldfrac(ncol,k)) ! In-cloud liquid water path.
- end do
-
-! Mukul
-!..The ice water path is already sum of cloud ice and snow, but when we have explicit
-!.. ice effective radius, overwrite the ice path with only the cloud ice variable,
-!.. leaving out the snow for its own effect.
- if(iceflgsw.ge.4)then
- do k = kts, kte
- gicewp = qi1d(k) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path.
- cicewp(ncol,k) = gicewp / max(0.01,cldfrac(ncol,k)) ! In-cloud ice water path.
- end do
- end if
-
-!..Here the snow path is adjusted if (radiation) effective radius of snow is
-!.. larger than what we currently have in the lookup tables. Since mass goes
-!.. rather close to diameter squared, adjust the mixing ratio of snow used
-!.. to compute its water path in combination with the max diameter. Not a
-!.. perfect fix, but certainly better than using all snow mass when diameter is
-!.. far larger than table currently contains and crystal sizes much larger than
-!.. about 140 microns have lesser impact than those much smaller sizes.
-
- if(iceflgsw.eq.5)then
- do k = kts, kte
- snow_mass_factor = 1.0
- if (resnow1d(ncol,k) .gt. 130.)then
- snow_mass_factor = (130.0/resnow1d(ncol,k))*(130.0/resnow1d(ncol,k))
- resnow1d(ncol,k) = 130.0
- endif
- gsnowp = qs1d(k) * snow_mass_factor * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box snow water path.
- csnowp(ncol,k) = gsnowp / max(0.01,cldfrac(ncol,k))
- end do
- end if
-
-
-!link the aerosol feedback to cloud -czhao
- if( PRESENT( progn ) ) then
- if (progn == 1) then
-!jdfcz if(prescribe==0) then
-
- pi = 4.*atan(1.0)
- third=1./3.
- rhoh2o=1.e3
- relconst=3/(4.*pi*rhoh2o)
-! minimun liquid water path to calculate rel
-! corresponds to optical depth of 1.e-3 for radius 4 microns.
- lwpmin=3.e-5
- do k = kts, kte
- reliq(ncol,k) = 10.
- if( PRESENT( F_QNDROP ) ) then
- if( F_QNDROP ) then
- if ( qc1d(k)*pdel(ncol,k).gt.lwpmin.and. &
- qndrop1d(k).gt.1000. ) then
- reliq(ncol,k)=(relconst*qc1d(k)/qndrop1d(k))**third ! effective radius in m
-! apply scaling from Martin et al., JAS 51, 1830.
- reliq(ncol,k)=1.1*reliq(ncol,k)
- reliq(ncol,k)=reliq(ncol,k)*1.e6 ! convert from m to microns
- reliq(ncol,k)=max(reliq(ncol,k),4.)
- reliq(ncol,k)=min(reliq(ncol,k),20.)
- end if
- end if
- end if
- end do
-!jdfcz else ! prescribe
-! following Kiehl
-! call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
-! write(0,*) 'sw prescribe aerosol',maxval(qndrop3d)
-!jdfcz endif
- else ! progn (progn=1)
- call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
- endif
- else !progn (PRESENT)
- call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
- endif
-
-! following Kristjansson and Mitchell
- call reicalc(ncol, pcols, pver, tlay, reice)
-
-
-
-!..If we already have effective radius of cloud and ice, then just overwrite what
-!.. was computed in the relcalc and reicalc subroutines above.
-
- if (inflgsw .ge. 3) then
- do k = kts, kte
- reliq(ncol,k) = recloud1d(ncol,k)
- end do
- endif
-#if (EM_CORE==1)
- if (iceflgsw .ge. 4) then
-#else
- if (iceflgsw .ge. 3) then !BSF: was .ge. 4
-#endif
- do k = kts, kte
- reice(ncol,k) = reice1d(ncol,k)
- end do
- endif
-
-
-#if 0
- if (i==80.and.j==30) then
-#if defined( DM_PARALLEL ) && ! defined( STUBMPI)
- if( PRESENT( progn ) ) write(0,*) 'aerosol indirect',progn
- write(0,*)'sw water eff radius',reliq(ncol,10),reliq(ncol,20),reliq(ncol,25)
- write(0,*)'sw ice eff radius',reice(ncol,10),reice(ncol,20),reice(ncol,25)
-#endif
- endif
-#endif
-
-
-! Limit upper bound of reice for Fu ice parameterization and convert
-! from effective radius to generalized effective size (*1.0315; Fu, 1996)
- if (iceflgsw .eq. 3) then
- do k = kts, kte
- reice(ncol,k) = reice(ncol,k) * 1.0315
- reice(ncol,k) = min(140.0,reice(ncol,k))
- end do
- endif
-
-!if CAMMGMP is used, use output from CAMMGMP
-!PMA
- if(is_CAMMGMP_used) then
- do k = kts, kte
- if ( qi1d(k) .gt. 1.e-20 .or. qs1d(k) .gt. 1.e-20) then
- reice(ncol,k) = iradius(i,k,j)
- else
- reice(ncol,k) = 25.
- end if
- reice(ncol,k) = max(5., min(140.0,reice(ncol,k)))
- if ( qc1d(k) .gt. 1.e-20) then
- reliq(ncol,k) = lradius(i,k,j)
- else
- reliq(ncol,k) = 10.
- end if
- reliq(ncol,k) = max(2.5, min(60.0,reliq(ncol,k)))
- enddo
- endif
-
-! Set cloud physical property arrays
- do k = kts, kte
- clwpth(ncol,k) = cliqwp(ncol,k)
- ciwpth(ncol,k) = cicewp(ncol,k)
- rel(ncol,k) = reliq(ncol,k)
- rei(ncol,k) = reice(ncol,k)
- enddo
-
-!Mukul
- if (inflgsw .eq. 5) then
- do k = kts, kte
- cswpth(ncol,k) = csnowp(ncol,k)
- res(ncol,k) = resnow1d(ncol,k)
- end do
- else
- do k = kts, kte
- cswpth(ncol,k) = 0.0
- res(ncol,k) = 10.0
- end do
- endif
-
-! Zero out cloud optical properties here, calculated in radiation
- do k = kts, kte
- do nb = 1, nbndsw
- taucld(nb,ncol,k) = 0.0
- ssacld(nb,ncol,k) = 1.0
- asmcld(nb,ncol,k) = 0.0
- fsfcld(nb,ncol,k) = 0.0
- enddo
- enddo
- endif
-
-! No clouds are allowed in the extra layer from model top to TOA
- clwpth(ncol,kte+1) = 0.
- ciwpth(ncol,kte+1) = 0.
- cswpth(ncol,kte+1) = 0.
- rel(ncol,kte+1) = 10.
- rei(ncol,kte+1) = 10.
- res(ncol,kte+1) = 10.
- cldfrac(ncol,kte+1) = 0.
- do nb = 1, nbndsw
- taucld(nb,ncol,kte+1) = 0.
- ssacld(nb,ncol,kte+1) = 1.
- asmcld(nb,ncol,kte+1) = 0.
- fsfcld(nb,ncol,kte+1) = 0.
- enddo
-
- iplon = 1
- irng = 0
- permuteseed = 1
-
-! Sub-column generator for McICA
-! mji - Add layer height needed for exponential (icld=4) and exponential-random (icld=5) overlap options
- call mcica_subcol_sw(iplon, ncol, nlay, icld, permuteseed, irng, play, hgt, &
- cldfrac, ciwpth, clwpth, cswpth, rei, rel, res, taucld, ssacld, asmcld, fsfcld, &
- cldfmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, &
- taucmcl, ssacmcl, asmcmcl, fsfcmcl)
-
-
-!--------------------------------------------------------------------------
-! Aerosol optical depth, single scattering albedo and asymmetry parameter -czhao 03/2010
-!--------------------------------------------------------------------------
-! by layer for each RRTMG shortwave band
-! No aerosols in top layer above model top (kte+1).
-!cz do nb = 1, nbndsw
-!cz do k = kts, kte+1
-!cz tauaer(ncol,k,nb) = 0.
-!cz ssaaer(ncol,k,nb) = 1.
-!cz asmaer(ncol,k,nb) = 0.
-!cz enddo
-!cz enddo
-
-! ... Aerosol effects. Added aerosol feedbacks from Chem , 03/2010 -czhao
-!
- do nb = 1, nbndsw
- do k = kts,kte+1
- tauaer(ncol,k,nb) = 0.
- ssaaer(ncol,k,nb) = 1.
- asmaer(ncol,k,nb) = 0.
-
- INMASS_ws(1) = mass_ws_i(i,k,j)
- INMASS_ws(2) = mass_ws_j(i,k,j)
- INMASS_ws(3) = mass_ws_k(i,k,j)
- INMASS_in(1) = mass_in_i(i,k,j)
- INMASS_in(2) = mass_in_j(i,k,j)
- INMASS_in(3) = mass_in_k(i,k,j)
- INMASS_ec(1) = mass_ec_i(i,k,j)
- INMASS_ec(2) = mass_ec_j(i,k,j)
- INMASS_ec(3) = mass_ec_k(i,k,j)
- INMASS_ss(1) = mass_ss_i(i,k,j)
- INMASS_ss(2) = mass_ss_j(i,k,j)
- INMASS_ss(3) = mass_ss_k(i,k,j)
- INMASS_h2o(1) = mass_h2o_i(i,k,j)
- INMASS_h2o(2) = mass_h2o_j(i,k,j)
- INMASS_h2o(3) = mass_h2o_k(i,k,j)
- INDGN(1) = dgn_i(i,k,j)
- INDGN(2) = dgn_j(i,k,j)
- INDGN(3) = dgn_k(i,k,j)
- INSIG(1) = sig_i(i,k,j)
- INSIG(2) = sig_j(i,k,j)
- INSIG(3) = sig_k(i,k,j)
-
- delta_z = dz8w(i,k,j)
-
- call get_aerosol_Optics_RRTMG_SW( nb,nmode,delta_z, &
- INMASS_ws, INMASS_in, INMASS_ec, INMASS_ss, &
- INMASS_h2o, INDGN, INSIG, &
- xtauaer, waer, gaer )
-
- write (mystr, *) xtauaer
- if (trim(mystr) == ' NaN') then
- write (6, '(a13, 2i5)') ' ==d== ', nb, nmode
- write (6, '(a13, 5e18.10)') ' ==d== delta ', delta_z
- write (6, '(a13, 5e18.10)') ' ==d== ws ', INMASS_ws
- write (6, '(a13, 5e18.10)') ' ==d== in ', INMASS_in
- write (6, '(a13, 5e18.10)') ' ==d== ec ', INMASS_ec
- write (6, '(a13, 5e18.10)') ' ==d== ss ', INMASS_ss
- write (6, '(a13, 5e18.10)') ' ==d== h2o ', INMASS_h2o
- write (6, '(a13, 5e18.10)') ' ==d== indgn ', INDGN
- write (6, '(a13, 5e18.10)') ' ==d== insig ', INSIG
- end if
-
- if (nb == 11) then
- gtauxar_01 (i,k,j) = xtauaer
- asy_fac_01 (i,k,j) = gaer
- ssa_01 (i,k,j) = waer
- else if (nb == 10) then
- gtauxar_02 (i,k,j) = xtauaer
- asy_fac_02 (i,k,j) = gaer
- ssa_02 (i,k,j) = waer
- else if (nb == 9) then
- gtauxar_03 (i,k,j) = xtauaer
- asy_fac_03 (i,k,j) = gaer
- ssa_03 (i,k,j) = waer
- else if (nb == 8) then
- gtauxar_04 (i,k,j) = xtauaer
- asy_fac_04 (i,k,j) = gaer
- ssa_04 (i,k,j) = waer
- else if (nb == 7) then
- gtauxar_05 (i,k,j) = xtauaer
- asy_fac_05 (i,k,j) = gaer
- ssa_05 (i,k,j) = waer
- end if
-
- tauaer(ncol,k,nb) = xtauaer
- ssaaer(ncol,k,nb) = waer
- asmaer(ncol,k,nb) = gaer
-
- enddo ! loop over layers
-! No aerosols in top layer above model top (kte+1).
- tauaer(ncol, kte+1 ,nb) = 0.
- ssaaer(ncol, kte+1 ,nb) = 1.
- asmaer(ncol, kte+1 ,nb) = 0.
- enddo ! loop over wavelengths
-
- if ( associated (tauaer3d_sw) ) then
-! ---- jararias 11/2012
- do nb=1,nbndsw
- do k=kts,kte
- tauaer(ncol,k,nb)=tauaer3d_sw(i,k,j,nb)
- ssaaer(ncol,k,nb)=ssaaer3d_sw(i,k,j,nb)
- asmaer(ncol,k,nb)=asyaer3d_sw(i,k,j,nb)
- end do
- end do
- end if
-
-#if ( WRF_CHEM == 1 )
- IF ( AER_RA_FEEDBACK == 1) then
- do nb = 1, nbndsw
- wavemid(nb)=0.5*(wavemin(nb)+wavemax(nb)) ! um
- do k = kts,kte !wig
-
-! convert optical properties at 300,400,600, and 999 to conform to the band wavelengths
-! tauaer - use angstrom exponent
- if(tauaer300(i,k,j).gt.thresh .and. tauaer999(i,k,j).gt.thresh) then
- ang=alog(tauaer300(i,k,j)/tauaer999(i,k,j))/alog(999./300.)
- tauaer(ncol,k,nb)=tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
- !tauaer(ncol,k,nb)=tauaer600(i,k,j)*(0.6/wavemid(nb))**ang
- if (i==30.and.j==49.and.k==2.and.nb==12) then
- write(0,*) 'TAU from 600 vs 400 in RRTMG',tauaer600(i,k,j),tauaer400(i,k,j)
- print*, 'TAU from 600 vs 400 in RRTMG',tauaer600(i,k,j),tauaer400(i,k,j)
- write(0,*) tauaer600(i,k,j)*(0.6/wavemid(nb))**ang,tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
- print*, tauaer600(i,k,j)*(0.6/wavemid(nb))**ang,tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
- endif
-! ssa - linear interpolation; extrapolation
- slope=(waer600(i,k,j)-waer400(i,k,j))/.2
- ssaaer(ncol,k,nb) = slope*(wavemid(nb)-.6)+waer600(i,k,j)
- if(ssaaer(ncol,k,nb).lt.0.4) ssaaer(ncol,k,nb)=0.4
- if(ssaaer(ncol,k,nb).ge.1.0) ssaaer(ncol,k,nb)=1.0
-! g - linear interpolation;extrapolation
- slope=(gaer600(i,k,j)-gaer400(i,k,j))/.2
- asmaer(ncol,k,nb) = slope*(wavemid(nb)-.6)+gaer600(i,k,j) ! notice reversed varaibles
- if(asmaer(ncol,k,nb).lt.0.5) asmaer(ncol,k,nb)=0.5
- if(asmaer(ncol,k,nb).ge.1.0) asmaer(ncol,k,nb)=1.0
- endif
- end do ! k
- end do ! nb
-
-!wig beg
- do nb = 1, nbndsw
- slope = 0. !use slope as a sum holder
- do k = kts,kte
- slope = slope + tauaer(ncol,k,nb)
- end do
- if( slope < 0. ) then
- write(msg,'("ERROR: Negative total optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb
- call wrf_error_fatal(msg)
- else if( slope > 6. ) then
- call wrf_message("-------------------------")
- write(msg,'("WARNING: Large total sw optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb
- call wrf_message(msg)
-
- call wrf_message("Diagnostics 1: k, tauaer300, tauaer400, tauaer600, tauaer999, tauaer")
- do k=kts,kte
- write(msg,'(i4,5f8.2)') k, tauaer300(i,k,j), tauaer400(i,k,j), &
- tauaer600(i,k,j), tauaer999(i,k,j),tauaer(ncol,k,nb)
- call wrf_message(msg)
- !czhao set an up-limit here to avoid segmentation fault
- !from extreme AOD
- tauaer(ncol,k,nb)=tauaer(ncol,k,nb)*6.0/slope
- end do
-
- call wrf_message("Diagnostics 2: k, gaer300, gaer400, gaer600, gaer999")
- do k=kts,kte
- write(msg,'(i4,4f8.2)') k, gaer300(i,k,j), gaer400(i,k,j), &
- gaer600(i,k,j), gaer999(i,k,j)
- call wrf_message(msg)
- end do
-
- call wrf_message("Diagnostics 3: k, waer300, waer400, waer600, waer999")
- do k=kts,kte
- write(msg,'(i4,4f8.2)') k, waer300(i,k,j), waer400(i,k,j), &
- waer600(i,k,j), waer999(i,k,j)
- call wrf_message(msg)
- end do
-
- call wrf_message("Diagnostics 4: k, ssaal, asyal, taual")
- do k=kts-1,kte
- write(msg,'(i4,3f8.2)') k, ssaaer(i,k,nb), asmaer(i,k,nb), tauaer(i,k,nb)
- call wrf_message(msg)
- end do
- call wrf_message("-------------------------")
- endif
- enddo ! nb
- endif ! aer_ra_feedback
-#endif
-
-
-! Zero array for input of aerosol optical thickness for use with
-! ECMWF aerosol types (not used)
- do na = 1, naerec
- do k = kts, kte+1
- ecaer(ncol,k,na) = 0.
- enddo
- enddo
-
- IF ( PRESENT( aerod ) ) THEN
- if ( aer_opt .eq. 0 ) then
- do na = 1, naerec
- do k = kts, kte+1
- ecaer(ncol,k,na) = 0.
- enddo
- enddo
- else if ( aer_opt .eq. 1 ) then
- do na = 1, naerec
- do k = kts, kte
- ecaer(ncol,k,na) = aerod(i,k,j,na)
- enddo
-! assuming 0 or same value at the top?
-! ecaer(ncol,kte+1,na) = ecaer(ncol,kte,na)
- ecaer(ncol,kte+1,na) = 0.
- enddo
- endif
- ENDIF
-
-! Call RRTMG shortwave radiation model
-
- call rrtmg_sw &
- (ncol ,nlay ,icld , &
- play ,plev ,tlay ,tlev ,tsfc , &
- h2ovmr , o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , &
- asdir ,asdif ,aldir ,aldif , &
- coszen ,adjes ,dyofyr ,scon , &
- inflgsw ,iceflgsw,liqflgsw,cldfmcl , &
- taucmcl ,ssacmcl ,asmcmcl ,fsfcmcl , &
- ciwpmcl ,clwpmcl ,cswpmcl, reicmcl ,relqmcl ,resnmcl, &
- tauaer ,ssaaer ,asmaer ,ecaer , &
- swuflx ,swdflx ,swhr ,swuflxc ,swdflxc ,swhrc, swuflxcln, swdflxcln, aer_opt, &
-! ----- Zhenxin added for ssib coupiling 2011-06-20 --------!
- sibvisdir, sibvisdif, sibnirdir, sibnirdif, &
-! -------------------- End of addiation by Zhenxin 2011-06-20 ------!
- swdkdir, swdkdif, & ! jararias, 2012/08/10
- swdkdirc & ! PAJ
- ,calc_clean_atm_diag &
- )
-
-
-! Output net absorbed shortwave surface flux and shortwave cloud forcing
-! at the top of atmosphere (W/m2)
- gsw(i,j) = swdflx(1,1) - swuflx(1,1)
- swcf(i,j) = (swdflx(1,kte+2) - swuflx(1,kte+2)) - (swdflxc(1,kte+2) - swuflxc(1,kte+2))
-
- if (present(swupt)) then
-! Output up and down toa fluxes for total and clear sky
- swupt(i,j) = swuflx(1,kte+2)
- swuptc(i,j) = swuflxc(1,kte+2)
- swdnt(i,j) = swdflx(1,kte+2)
- swdntc(i,j) = swdflxc(1,kte+2)
-! Output up and down surface fluxes for total and clear sky
- swupb(i,j) = swuflx(1,1)
- swupbc(i,j) = swuflxc(1,1)
- swdnb(i,j) = swdflx(1,1)
-! Added by Zhenxin for 4 compenants of swdown radiation
- swvisdir(i,j) = sibvisdir(1,1)
- swvisdif(i,j) = sibvisdif(1,1)
- swnirdir(i,j) = sibnirdir(1,1)
- swnirdif(i,j) = sibnirdif(1,1)
-! Ended, Zhenxin (2011/06/20)
- swdnbc(i,j) = swdflxc(1,1)
- if(calc_clean_atm_diag .gt. 0)then
- swuptcln(i,j) = swuflxcln(1,kte+2)
- swdntcln(i,j) = swdflxcln(1,kte+2)
- swupbcln(i,j) = swuflxcln(1,1)
- swdnbcln(i,j) = swdflxcln(1,1)
- end if
- endif
- swddir(i,j) = swdkdir(1,1) ! jararias 2013/08/10
- swddni(i,j) = swddir(i,j) / coszrs ! jararias 2013/08/10
- swddif(i,j) = swdkdif(1,1) ! jararias 2013/08/10
- swdownc(i, j) = swdflxc(1,1) ! PAJ: clear-sky GHI
- swddirc(i,j) = swdkdirc(1,1) ! PAJ: clear-sky direct normal irradiance
- swddnic(i,j) = swddirc(i,j) / coszrs ! PAJ: clear-sky direct normal irradiance
-
-! Output up and down layer fluxes for total and clear sky.
-! Vertical ordering is from bottom to top in units of W m-2.
- if ( present (swupflx) ) then
- do k=kts,kte+2
- swupflx(i,k,j) = swuflx(1,k)
- swupflxc(i,k,j) = swuflxc(1,k)
- swdnflx(i,k,j) = swdflx(1,k)
- swdnflxc(i,k,j) = swdflxc(1,k)
- enddo
- endif
-
-! Output heating rate tendency; convert heating rate from K/d to K/s
-! Heating rate arrays are ordered vertically from bottom to top here.
- do k=kts,kte
- tten1d(k) = swhr(ncol,k)/86400.
- rthratensw(i,k,j) = tten1d(k)/pi3d(i,k,j)
- enddo
- else
-
-! =s= WRF-CMAQ twoway coupled model
- gtauxar_01 (i,:,j) = 0.0
- gtauxar_02 (i,:,j) = 0.0
- gtauxar_03 (i,:,j) = 0.0
- gtauxar_04 (i,:,j) = 0.0
- gtauxar_05 (i,:,j) = 0.0
- asy_fac_01 (i,:,j) = 0.0
- asy_fac_02 (i,:,j) = 0.0
- asy_fac_03 (i,:,j) = 0.0
- asy_fac_04 (i,:,j) = 0.0
- asy_fac_05 (i,:,j) = 0.0
- ssa_01 (i,:,j) = 0.0
- ssa_02 (i,:,j) = 0.0
- ssa_04 (i,:,j) = 0.0
- ssa_04 (i,:,j) = 0.0
- ssa_05 (i,:,j) = 0.0
-! =e= WRF-CMAQ twoway coupled model
-
- if (present(swupt)) then
-! Output up and down toa fluxes for total and clear sky
- swupt(i,j) = 0.
- swuptc(i,j) = 0.
- swdnt(i,j) = 0.
- swdntc(i,j) = 0.
-! Output up and down surface fluxes for total and clear sky
- swupb(i,j) = 0.
- swupbc(i,j) = 0.
- swdnb(i,j) = 0.
- swdnbc(i,j) = 0.
- swvisdir(i,j) = 0. ! Add by Zhenxin (2011/06/20)
- swvisdif(i,j) = 0.
- swnirdir(i,j) = 0.
- swnirdif(i,j) = 0. ! Add by Zhenxin (2011/06/20)
- if(calc_clean_atm_diag .gt. 0)then
- swuptcln(i,j) = 0.
- swdntcln(i,j) = 0.
- swupbcln(i,j) = 0.
- swdnbcln(i,j) = 0.
- end if
- endif
- swddir(i,j) = 0. ! jararias 2013/08/10
- swddni(i,j) = 0. ! jararias 2013/08/10
- swddif(i,j) = 0. ! jararias 2013/08/10
- swdownc(i, j) = 0.0 ! PAJ
- swddnic(i,j) = 0.0 ! PAJ
- swddirc(i,j) = 0.0 ! PAJ
- swcf(i,j) = 0.
-
- endif
-!
- end do i_loop
- end do j_loop
-
- END SUBROUTINE RRTMG_SWRAD2
-
-!------------------------------------------------------------------
- Subroutine get_aerosol_Optics_RRTMG_SW ( ns, nmode,delta_z, INMASS_ws, &
- INMASS_in, INMASS_ec, INMASS_ss, &
- INMASS_h2o, INDGN, INSIG, &
- tauaer, waer, gaer )
-
-!FSB This version switches between BHCOAT to BHMIE depending upon whether
-! EC is present or not. 04/15/2012.
-
-!FSB this version does a core-shell calculation with BHCOAT 04/11/2012
-! This version is set up to be used with RRTMG_SW <<<<<<<<
-! wavelenght is calculated internally
-! FSB This routine calculates the aerosol information ( tauaer, waer,
-! gaer, needed to calculate the solar radiation) The calling
-! program specifies the location ( row, column, layer,
-! layer thicknes, and wave length for the calculation.
-! FSB 02/09/2011 Modifications made to subroutine ghintBH.
-! FSB 04/14/2012 REmoved MODULUS, made changes to ghintBH.
-! Put in option for core-shell (coated-sphere). 2
-
-! FSB Input variables:
-
- use rrtmg_aero_optical_util_module
-
- implicit none
-
- integer,intent(in) :: ns ! index for wavelength should be
- ! between 1 and 14. <<< RRTMG_SW
- integer,intent(in) :: nmode ! should be 3 for WRF/CMAQ calculation
- real,intent(in) :: delta_z ! layer thickness [m]
-! FSB mode types for WRF/CMAQ
-! nmode = 1 Aitken
-! nmode = 2 accumulation
-! nmode = 3 coarse
-! FSB modal mass concentration by species [ ug / m**3] NOTE: MKS
- real, intent(in) :: INMASS_ws(nmode) ! water soluble
- real, intent(in) :: INMASS_in(nmode) ! insolugle
- real, intent(in) :: INMASS_ec(nmode) ! elemental carbon or soot like
- real, intent(in) :: INMASS_ss(nmode) ! sea salt
- real, intent(in) :: INMASS_h2o(nmode) ! water
-! FSB particle size-distribution information
- real, intent(in) :: INDGN( nmode) ! geometric mean diameter [ m ] NOTE: MKS
- real, intent(in) :: INSIG( nmode) ! geometric standard deviation
-
-!FSB output aerosol radiative properties [dimensionless]
- real, intent(out) :: tauaer ! aerosol extinction optical depth
- real, intent(out) :: waer ! aerosol single scattering albedo
- real, intent(out) :: gaer ! aerosol assymetry parameter
-
-! FSB Internal variables
-
- real :: NR(nmode), NI(nmode) ! refractive indices
- complex :: refcor(nmode), refshell(nmode) ! complex refracive indices
- complex :: crefin(nmode) ! complex refractive index
-
-! FSB special values for EC CORE-shell calculation
- real :: DGNSHELL(nmode) ! modal geometric mean diameter [m]
- real :: DGNCORE (nmode) ! modal geometric mean diameter [m]
-
-! FSB Modal volumes [ m**3 / m**3 ]
- real :: MVOL_ws(nmode) ! water soluble
- real :: MVOL_in(nmode) ! insolugle
- real :: MVOL_ec(nmode) ! soot like
- real :: MVOL_ss(nmode) !sea salt
- real :: MVOL_h2o(nmode) ! water
-! real :: VOL(nmode) ! total modal volume [m** 3 / m**3]
-! FSB special values for EC CORE-shell calculation
- real :: VOLCOR(nmode) ! volume of EC core [m** 3 / m**3]
- real :: VOLSHELL(nmode) ! volume of shell [m** 3 / m**3]
-
- integer :: m ! loop index
- real :: bext ! extinction coefficient [1 / m]
- real :: bscat ! scattering coefficient [1 / m]
- real :: gfac ! asymmetry factor
-
- real :: bextsum, bscatsum, bsgsum
-
-! FSB History variables by wavelength and mode
-! real :: bext_wm(ns,nmode)
-! real :: bscat_wm(ns,nmode)
-! real :: gfac_wm(ns,nmode)
-
- real, parameter :: one3rd = 1.0 / 3.0
- real :: dfac ! ratio of (volcor/vol) ** one3rd
- ! used for calculating the diameter
- ! of the EC core
-
- logical :: succesS
-
-!...component densities [ g/ cm**3 ] <<<<< cgs
-
- real, parameter :: rhows = 1.8 ! bulk density of water soluble aerosol
-
- real, parameter :: rhoin = 2.2 ! bulk density forinsoluble aerosol
-
-! real, parameter :: rhoec = 1.7 ! bulk density for soot aerosol
- real, parameter :: rhoec = 1.8 ! new value
-
- real, parameter :: rhoh2o = 1.0 ! bulk density of aerosol water
-
- real, parameter :: rhoss = 2.2 ! bulk density of seasalt
-
-! FSB scale factor for volume calculation
-! 1.0d-12 * [ cm**3 / g] -> [ m** 3 / ug ]
- real, parameter :: scalefactor = 1.0e-12
-
-! FSB scale factor for [1/g] to [1/ug]
- real, parameter :: cug2g = 1.0e-06
-
-! FSB reciprocal component densities[ m ** 3 / ug ]
-
- real, parameter :: rhows1 = scalefactor / rhows ! water soluble aerosol
-
- real, parameter :: rhoin1 = scalefactor / rhoin ! insoluble aerosol
-
- real, parameter :: rhoec1 = scalefactor / rhoec ! soot aerosol
-
- real, parameter :: rhoh2o1 = scalefactor / rhoh2o ! aerosol water
-
- real, parameter :: rhoss1 = scalefactor / rhoss ! seasalt
-
- integer,parameter :: nspint_sw = 14 ! number of spectral intervals for RRTMG_SW
-
-! FSB Band numbers and wavelengths for RRTMG_SW
- integer, parameter :: Band(nspint_sw) = (/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14 /)
-
- real, parameter :: LAMDA_SW(nspint_sw) = (/ 3.4615, 2.7885, 2.325, 2.046, 1.784, &
- 1.4625, 1.2705, 1.0101, 0.7016, 0.53325, &
- 0.38815, 0.299, 0.2316, 8.24 /) ! wavelength [ um ]
-
-! *** refractive indices
-
-! *** Except as otherwise noted reference values of refractive
-! indices for aerosol particles are from the OPAC Data base.
-! Hess, Koepke, and Schult, Optical properties of
-! aerosols and clouds: The software package OPAC, Bulletan of
-! the American Meteorological Society, Vol 79, No 5,
-! pp 831 - 844, May 1998.
-! OPAC is a downloadable data set of optical properties of
-! 10 aerosol components, 6 water clouds and 3 cirrus clouds
-! at UV, visible and IR wavelengths
-! www.lrz-muenchen.de/~uh234an/www/radaer/opac.htm
-
-
-! FSB water soluble
- real, parameter :: xnreal_ws(nspint_sw) = (/ 1.443, 1.420, 1.420, 1.420, 1.463, 1.510, 1.510, &
- 1.520, 1.530, 1.530, 1.530, 1.530, 1.530, 1.710 /)
- real, parameter :: xnimag_ws(nspint_sw) = (/ 5.718E-3, 1.777E-2, 1.060E-2, 8.368E-3, 1.621E-2, &
- 2.198E-2, 1.929E-2, 1.564E-2, 7.000E-3, 5.666E-3, &
- 5.000E-3, 8.440E-3, 3.000E-2, 1.100E-1 /)
-
-! FSB sea salt
- real, parameter :: xnreal_ss(nspint_sw) = (/ 1.480, 1.534, 1.437, 1.448, 1.450, 1.462, 1.469, &
- 1.470, 1.490, 1.500, 1.502, 1.510, 1.510, 1.510 /)
-
- real, parameter :: xnimag_ss(nspint_sw) = (/ 1.758E-3, 7.462E-3, 2.950E-3, 1.276E-3, 7.944E-4, &
- 5.382E-4, 3.754E-4, 1.498E-4, 2.050E-7, 1.184E-8, &
- 9.938E-8, 2.060E-6, 5.000E-6, 1.000E-2 /)
-
-! FSB insoluble
- real, parameter :: xnreal_in(nspint_sw) = (/ 1.272, 1.168, 1.208, 1.253, 1.329, 1.418, 1.456, &
- 1.518, 1.530, 1.530, 1.530, 1.530, 1.530, 1.470 /)
- real, parameter :: xnimag_in(nspint_sw) = (/ 1.165E-2, 1.073E-2, 8.650E-3, 8.092E-3, 8.000E-3, &
- 8.000E-3, 8.000E-3, 8.000E-3, 8.000E-3, 8.000E-3, &
- 8.000E-3, 8.440E-3, 3.000E-2,9.000E-2 /)
-
-! FSB 02/11/2012 These values are replaced.
-! data xnreal_ec /1.877, 1.832, 1.813, 1.802, 1.791, 1.769, 1.761, &
-! 1.760, 1.750, 1.740, 1.750, 1.738, 1.620, 2.120/
-! data xnimag_ec/ 5.563E-1, 5.273E-1, 5.030E-1, 4.918E-1, 4.814E-1, &
-! 4.585E-1, 4.508E-1, 4.404E-1, 4.300E-1, 4.400E-1, &
-! 4.600E-1, 4.696E-1, 4.500E-1, 5.700E-1/
-
-! New Refractive indices for EC at RRTMG Wavelengths
-! Source lamda xnreal_ec xnimag_ec
-! C&C Values
-! 3.4615 2.089 1.070
-! 2.7885 2.014 0.939
-! 2.325 1.962 0.843
-! 2.046 1.950 0.784
-! Bond values
-! 1.784 1.940 0.760
-! 1.4625 1.930 0.749
-! 1.2705 1.905 0.737
-! 1.0101 1.870 0.726
-! B&B Values
-! 0.7016 1.85 0.71
-! 0.53325 1.85 0.71
-! 0.38815 1.85 0.71
-! 0.299 1.85 0.71
-! 0.2316 1.85 0.71
-! C & C values
-! 8.24 2.589 1.771
-!References:
-! Bond Personal Communication from Tami Bond
-! B&B Bond, T.C. & R.W. Bergstrom (2006) Light absorption by
-! Carbonaceous Particles: An investigative review,
-! Aerosol Science and Technology. Vol. 40. pp 27-67
-!
-! C&C Chang,H and T.T. Charalmpopoulos (1990) Determination of the
-! wavelength dependence of refractive indices of flame soot,
-! Proceeding of the Royal Society of London A, Vol. 430, pp 577-591.
-! FSB new values
-
-! FSB elemental carbon - soot like
-
- real, parameter :: xnreal_ec(nspint_sw) = (/ 2.089, 2.014, 1.962, 1.950, 1.940, 1.930, 1.905, &
- 1.870, 1.85, 1.85, 1.85, 1.85, 1.85, 2.589 /)
- real, parameter :: xnimag_ec(nspint_sw) = (/ 1.070, 0.939, 0.843, 0.784, 0.760, 0.749, 0.737, &
- 0.726, 0.71, 0.71, 0.71, 0.71, 0.71, 1.771 /)
-
-! FSB water
- real, save :: xnreal_h2o(nspint_sw) = (/ 1.408, 1.324, 1.277, 1.302, 1.312, 1.321, 1.323, &
- 1.327, 1.331, 1.334, 1.340, 1.349, 1.362, 1.260 /)
- real, save :: xnimag_h2o(nspint_sw) = (/ 1.420E-2, 1.577E-1, 1.516E-3, 1.159E-3, 2.360E-4, &
- 1.713E-4, 2.425E-5, 3.125E-6, 3.405E-8, 1.639E-9, &
- 2.955E-9, 1.635E-8, 3.350E-8, 6.220E-2 /)
-
-
-! FSB Begin code ======================================================
-
- bextsum = 0.0
- bscatsum = 0.0
- bsgsum = 0.0
- do m = 1, nmode
-! FSB calculate volumes [ m**3 / m**3 ]
-! FSB the reciprocal densities have been scaled to [ m**3 / ug ]
-
- MVOL_ws(m) = rhows1 * INMASS_ws(m)
- MVOL_in(m) = rhoin1 * INMASS_in(m)
- MVOL_ec(m) = rhoec1 * INMASS_ec(m)
- MVOL_ss(m) = rhoss1 * INMASS_ss(m)
- MVOL_h2o(m) = rhoh2o1 * INMASS_h2o(m)
-
- VOLSHELL(m) = MVOL_ws(m) + MVOL_in(m) + MVOL_ss(m) + MVOL_h2o(m)
- VOLCOR(m) = MVOL_ec(m)
-! VOL(m) = VOLSHELL(m) + VOLCOR(m) ! VOL is total volume
-
- if ( VOLCOR(m) .gt. 0.0 ) then
-! FSB EC is present
-! calculate the ratio of core to shell volume
-! take cube root for scaling the diameter of
-! the core to that of the shell.
-
-! dfac = ( VOLCOR(m) / VOL(m) ) ** one3rd
- dfac = ( VOLCOR(m) / ( VOLSHELL(m) + VOLCOR(m) ) ) ** one3rd
-! dfac = ( VOLCOR(m) / ( VOLSHELL(m) + VOLCOR(m) ) )
-! FSB Set shell and core diameters
- DGNSHELL(m) = INDGN(m)
- DGNCORE(M) = dfac * INDGN(m)
-! FSB note that VOLSHELL(m) is the total volume when EC is not present
- end if
-
-! internal mixture of non-EC species.
-
-! modal real refractive index No EC
- nr(m) = (MVOL_ws(m) * xnreal_ws(ns) + &
- MVOL_in(m) * xnreal_in(ns) + &
- MVOL_ss(m) * xnreal_ss(ns) + &
-! MVOL_h2o(m) * xnreal_h2o(ns)) / VOL(m)
- MVOL_h2o(m) * xnreal_h2o(ns)) / VOLSHELL(m)
-
-! modal imaginary refractive index no EC
- ni(m) = (MVOL_ws(m) * xnimag_ws(ns) + &
- MVOL_in(m) * xnimag_in(ns) + &
- MVOL_ss(m) * xnimag_ss(ns) + &
-! MVOL_h2o(m) * xnimag_h2o(ns)) / VOL(m)
- MVOL_h2o(m) * xnimag_h2o(ns)) / VOLSHELL(m)
-
- if ( VOLCOR(m) .gt. 0.0) then
-
-! FSB calculate the complex refractive indices for the CORE and
-! the SHELL for case when and EC core is assumed to exist.
-
- refcor(m) = cmplx( xnreal_ec(ns), xnimag_ec(ns) )
- refshell(m) = cmplx(nr(m), ni(m) )
-! FSB do BHCOAT case
- CALL aero_optical_CS( LAMDA_SW(ns), refcor(m), refshell(m), &
- VOLCOR(m),VOLSHELL(m), DGNCORE(m), &
- DGNSHELL(m), INSIG(m), &
- bext, bscat, gfac, succesS )
-! else if ( VOL(m) .gt. 0.0) then
- else if ( VOLSHELL(m) .gt. 0.0) then
-! FSB do BHMIE case for the case when EC is not present.
- crefin(m) = cmplx(nr(m), ni(m) )
-! CALL aero_optical2( LAMDA_SW(ns), crefin(m), VOL(m), &
- CALL aero_optical2( LAMDA_SW(ns), crefin(m), VOLSHELL(m), &
- INDGN(m), INSIG(m), &
- bext, bscat, gfac, success )
- else
- bext = 0.0
- bscat = 0.0
- gfac = 0.0
- end if
-
-! FSB sum for total values
- bextsum = bextsum + bext
- bscatsum = bscatsum +bscat
- bsgsum = bsgsum + bscat * gfac
-! FSB get history
-! bext_wm(ns,m) = bext
-! bscat_wm(ns,m) = bscat
-! gfac_wm(ns,m) = gfac
- end do ! loop over modes
-
-! FSB construct output variables
- tauaer = bextsum * delta_z
- waer = bscatsum / bextsum
- gaer = bsgsum / bscatsum
-
-! Write out modal values.
-
-! write(100,*) ' lamda mode bext bscat gaer '
-! m=1
-! write(100,*) lamda(ns), m, bext_wm(ns,m),bscat_wm(ns,m), gfac_wm(ns,m)
-! m=2
-! write(100,*) lamda(ns), m, bext_wm(ns,m),bscat_wm(ns,m), gfac_wm(ns,m)
-! m=3
-! write(100,*) lamda(ns), m, bext_wm(ns,m),bscat_wm(ns,m), gfac_wm(ns,m)
-
- end subroutine get_aerosol_Optics_RRTMG_SW
-
-END MODULE module_twoway_ra_rrtmg_sw
diff --git a/UTIL/wrfcmaq_twoway_coupler/phys/module_twoway_rrtmg_aero_optical_util.F b/UTIL/wrfcmaq_twoway_coupler/phys/module_twoway_rrtmg_aero_optical_util.F
deleted file mode 100644
index e074d34fa5..0000000000
--- a/UTIL/wrfcmaq_twoway_coupler/phys/module_twoway_rrtmg_aero_optical_util.F
+++ /dev/null
@@ -1,2768 +0,0 @@
-! Revision History:
-! 2016/02/23 David Wong extracted the complex number module and put it in a file
-! 2016/05/23 David Wong - replaced rrtmg_aero_optical_util_module with
-! cmaq_rrtmg_aero_optical_util_module to avoid duplication
-! of the same module name on WRF side of the two-way model
-
-MODULE rrtmg_aero_optical_util_module
-
- Integer :: AERO_UTIL_LOG = 0
-
- private
- public :: aero_optical, aero_optical2, aero_optical_CS, AERO_UTIL_LOG
-
- interface ghintBH
- module procedure ghintBH_1, ghintBH_2, ghintBH_Odd
- end interface
-
- interface ghintBH_CS
- module procedure ghintBH_CS_even, ghintBH_CS_odd
- end interface
-
- Logical, Parameter :: Use_Odd_Quadrature = .True.
- Integer, Parameter :: Quadrature_Points = 3
-
-!B.Hutzell One point quadature IGH = 1
-
- real, parameter :: ghxi_1(1) = 0.00000000000
- real, parameter :: ghwi_1(1) = 1.77245385091
-
-!B.Hutzell Three point quadature IGH = 3
- real, parameter :: ghxi_3(3) = (/ -1.22474487139, &
- 0.00000000000, &
- 1.22474487139 /)
-
- real, parameter :: ghwi_3(3) = (/ 0.295408975151, &
- 1.181635900000, &
- 0.295408975151 /)
-
-!B.Hutzell Five point quadature IGH = 5
- real(8), parameter :: ghxi_5(5) = (/ -2.02018287046d0, &
- -0.958572464614d0, &
- 0.00000000000d0, &
- 0.958572464614d0, &
- 2.02018287046d0 /)
-
- real(8), parameter :: ghwi_5(5) = (/ 0.019953242059d0, &
- 0.393619323152d0, &
- 0.945308720483d0, &
- 0.393619323152d0, &
- 0.019953242059d0 /)
-
-!B.Hutzell Nine point quadature IGH = 9 points
-!No. Abscissas Weight Total Weight
- real, parameter :: ghxi_9(9) = (/ -3.19099320178, &
- -2.26658058453, &
- -1.46855328922, &
- -0.72355101875, &
- 0.00000000000, &
- 0.72355101875, &
- 1.46855328922, &
- 2.26658058453, &
- 3.19099320178 /)
-
- real, parameter :: ghwi_9(9) = (/ 3.96069772633E-5, &
- 0.00494362428, &
- 0.08847452739, &
- 0.43265155900, &
- 0.72023521561, &
- 0.43265155900, &
- 0.08847452739, &
- 0.004943624275, &
- 3.96069772633E-5 /)
-
- contains
-
-! ------------------------------------------------------------------
- subroutine getqext_BH (xx, crefin, qextalf, qscatalf, gscatalfg,SUCCESS)
-
- implicit none
-
- real, intent(in) :: XX
- real, intent(out) :: qextalf, qscatalf, gscatalfg
- complex, intent(in) :: CREFIN
- logical, intent(out) :: success
-
-! local variables
- real( 8 ), parameter :: one_third = 1.0d0 / 3.0d0
-
- integer :: NXX
- integer :: nstop, modulus
-
- real :: QEXT, QSCA, QBACK, G_MIE, xx1
-
- real( 8 ) :: x
- complex( 8 ) :: refractive_index
-
- x = real( XX, 8 )
- refractive_index = dcmplx( real( CREFIN ), imag( CREFIN ) )
-
- modulus = int( abs( x * refractive_index ) )
- nstop = int( x + 4.0d0 * x**one_third + 2.0d0 )
-
- nxx = max( modulus, nstop ) + 15
-
- xx1 = 1.0 / XX
-
- CALL BHMIE_FLEXI (XX, NXX, NSTOP, CREFIN,QEXT,QSCA,QBACK,G_MIE, SUCCESS)
-
- qextalf = QEXT * xx1
- qscatalf = QSCA * xx1
- gscatalfg = qscatalf * G_MIE
-
- end subroutine getqext_bh
-
-! ------------------------------------------------------------------
- SUBROUTINE BHMIE (X, REFREL, QQEXT, QQSCA, QBACK, GSCA, SUCCESS)
-
-! FSB Changed the call vector to return only QEXT, QSCAT QBACK GSCA
-! and ignore NANG, S1 and S2 and all calculations for them
-
- implicit none
-
-! Arguments:
- real, intent(in) :: X ! X = pi*particle_diameter / Wavelength
- complex, intent(in) :: REFREL
-
-! REFREL = (complex refr. index of sphere)/(real index of medium)
-! in the current use the index of refraction of the the medium
-! i taken at 1.0 real.
-!
-! Output
-
- real, intent(out) :: QQEXT, QQSCA, QBACK, GSCA
- logical, intent(out) :: SUCCESS
-
-! QQEXT Efficiency factor for extinction
-! QQSCA Efficiency factor for scattering
-! QQBACK Efficiency factor for back scatter
-! GSCA asymmetry factor
-! SUCCESS flag for successful calculation
-! REFERENCE:
-! Bohren, Craig F. and Donald R. Huffman, Absorption and
-! Scattering of Light by Small Particles, Wiley-Interscience
-! copyright 1983. Paperback Published 1998.
-! FSB
-! This code was originally listed in Appendix A. pp 477-482.
-! As noted below, the original code was subsequently
-! modified by Prof. Bruce T. Drain of Princetion University.
-! The code was further modified for a specific application
-! in a large three-dimensional code requiring as much
-! computational efficiency as possible.
-! Prof. Francis S. Binkowski of The University of North
-! Carolina at Chapel Hill.
-
-! Declare parameters:
-! Note: important that MXNANG be consistent with dimension of S1 and S2
-! in calling routine!
-
- integer, parameter :: MXNANG=10, NMXX=600000 ! FSB new limits
- real*8, parameter :: PII = 3.1415916536D0
- real*8, parameter :: ONE = 1.0D0, TWO = 2.0D0
-
-! Local variables:
- integer :: NANG
- integer :: N,NSTOP,NMX,NN
- real*8 :: QSCA, QEXT, DX1, DXX1
- real*8 :: CHI,CHI0,CHI1,DX,EN,P,PSI,PSI0,PSI1,XSTOP,YMOD
- real*8 :: TWO_N_M_ONE, TWO_N_P_ONE, EN1, FACTOR
- complex*16 :: AN,AN1,BN,BN1,DREFRL,XI,XI1,Y, Y1, DREFRL1
- complex*16 :: D(NMXX), FAC1, FAC2
- complex*16 :: XBACK
-
-!***********************************************************************
-! Subroutine BHMIE is the Bohren-Huffman Mie scattering subroutine
-! to calculate scattering and absorption by a homogenous isotropic
-! sphere.
-! Given:
-! X = 2*pi*a/lambda
-! REFREL = (complex refr. index of sphere)/(real index of medium)
-! real refractive index of medium taken as 1.0
-! Returns:
-! QEXT = efficiency factor for extinction
-! QSCA = efficiency factor for scattering
-! QBACK = efficiency factor for backscatter
-! see Bohren & Huffman 1983 p. 122
-! GSCA = asymmetry for scattering
-!
-! Original program taken from Bohren and Huffman (1983), Appendix A
-! Modified by Prof. Bruce T.Draine, Princeton Univ. Obs., 90/10/26
-! in order to compute
-! 91/05/07 (BTD): Modified to allow NANG=1
-! 91/08/15 (BTD): Corrected error (failure to initialize P)
-! 91/08/15 (BTD): Modified to enhance vectorizability.
-! 91/08/15 (BTD): Modified to make NANG=2 if called with NANG=1
-! 91/08/15 (BTD): Changed definition of QBACK.
-! 92/01/08 (BTD): Converted to full double precision and double complex
-! eliminated 2 unneed lines of code
-! eliminated redundant variables (e.g. APSI,APSI0)
-! renamed RN -> EN = double precision N
-! Note that DOUBLE COMPLEX and DCMPLX are not part
-! of f77 standard, so this version may not be fully
-! portable. In event that portable version is
-! needed, use src/bhmie_f77.f
-! 93/06/01 (BTD): Changed AMAX1 to generic function MAX
-! FSB April 09,2012 This code was modified by:
-! Prof. Francis S. Binkowski University of North Carolina at
-! Chapel Hill, Institue for the Environment.
-!
-! The modifications were made to enhance computation speed
-! for use in a three-dimensional code. This was done by
-! removing code that calculated angular scattering. The method
-! of calculating QEXT, QBACK was also changed.
-
-!***********************************************************************
-!*** Safety checks
-
- SUCCESS = .TRUE.
- NANG = 2 ! FSB only this value
-! IF(NANG.GT.MXNANG)STOP'***Error: NANG > MXNANG in bhmie'
-! IF (NANG .LT. 2) NANG = 2
-
- DX = REAL( X, 8 )
-! FSB Define reciprocals so that divisions can be replaced by multiplications.
- DX1 = ONE / DX
- DXX1 = DX1 * DX1
- DREFRL = DCMPLX( REFREL )
- DREFRL1 = ONE / DREFRL
- Y = DX * DREFRL
- Y1 = ONE / Y
- YMOD = ABS(Y)
-
-!*** Series expansion terminated after NSTOP terms
-! Logarithmic derivatives calculated from NMX on down
- XSTOP = REAL( X + 4.0 * X**0.3333 + 2.0, 8)
- NMX = INT( MAX(XSTOP,YMOD) ) + 15
-
-! BTD experiment 91/1/15: add one more term to series and compare results
-! NMX=AMAX1(XSTOP,YMOD)+16
-! test: compute 7001 wavelengths between .0001 and 1000 micron
-! for a=1.0micron SiC grain. When NMX increased by 1, only a single
-! computed number changed (out of 4*7001) and it only changed by 1/8387
-! conclusion: we are indeed retaining enough terms in series!
- NSTOP = INT( XSTOP )
- FACTOR = 1.0D0
-
- IF (NMX .GT. NMXX) THEN
- WRITE(6,*)'Error: NMX > NMXX=',NMXX,' for |m|x=',YMOD
- SUCCESS = .FALSE.
- RETURN
- END IF
-
-! FSB all code relating to scattering angles is removed out for
-! reasons of efficiency when running in a three-dimensional
-! code. We only need QQSCA, QQEXT, GSCA AND QBACK
-
-
-!*** Logarithmic derivative D(J) calculated by downward recurrence
-! beginning with initial value (0.,0.)
-
- D(NMX) = DCMPLX(0.0D0,0.0D0)
- NN = NMX - 1
- DO N = 1,NN
- EN = REAL(NMX - N + 1, 8 )
-! FSB In the following division by Y has been replaced by
-! multiplication by Y1, the reciprocal of Y.
- D(NMX-N) = ( EN * Y1 ) - (ONE / ( D(NMX-N+1) + EN * Y1))
- END DO
-
-!*** Riccati-Bessel functions with real argument X
-! calculated by upward recurrence
-
- PSI0 = COS(DX)
- PSI1 = SIN(DX)
- CHI0 = -SIN(DX)
- CHI1 = PSI0
- XI1 = DCMPLX(PSI1,-CHI1)
- QSCA = 0.0D0
- GSCA = 0.0D0
- QEXT = 0.0D0
- P = -ONE
- XBACK = (0.0d0,0.0d0)
-
-! FSB Start main loop
- DO N = 1,NSTOP
- EN = REAL( N, 8)
- EN1 = ONE / EN
- TWO_N_M_ONE = TWO * EN - ONE
-! for given N, PSI = psi_n CHI = chi_n
-! PSI1 = psi_{n-1} CHI1 = chi_{n-1}
-! PSI0 = psi_{n-2} CHI0 = chi_{n-2}
-! Calculate psi_n and chi_n
- PSI = TWO_N_M_ONE * PSI1 * DX1 - PSI0
- CHI = TWO_N_M_ONE * CHI1 * DX1 - CHI0
- XI = DCMPLX(PSI,-CHI)
-
-!*** Compute AN and BN:
-! FSB Rearrange to get common terms
- FAC1 = D(N) * DREFRL1 + EN * DX1
- AN = (FAC1) * PSI - PSI1
- AN = AN / ( (FAC1 )* XI - XI1 )
- FAC2 = ( DREFRL * D(N) + EN * DX1)
- BN = ( FAC2) * PSI -PSI1
- BN = BN / ((FAC2) * XI - XI1 )
-
-! FSB calculate sum for QEXT as done by Wiscombe
-! get common factor
- TWO_N_P_ONE = (TWO * EN + ONE)
- QEXT = QEXT + (TWO_N_P_ONE) * (REAL(AN) + REAL(BN) )
- QSCA = QSCA + (TWO_N_P_ONE) * ( ABS(AN)**2+ ABS(BN)**2 )
-
-! FSB calculate XBACK from B & H Page 122
- FACTOR = -1.0d0 * FACTOR ! calculate (-1.0 ** N)
- XBACK = XBACK + (TWO_N_P_ONE) * factor * (AN - BN)
-
-! FSB calculate asymmetry factor
- GSCA = GSCA + REAL( ((TWO_N_P_ONE)/(EN * (EN + ONE))) * &
- (REAL(AN)*REAL(BN)+IMAG(AN)*IMAG(BN)))
-
- IF (N .GT. 1)THEN
- GSCA = GSCA + REAL( (EN - EN1) * &
- (REAL(AN1)*REAL(AN) + IMAG(AN1)*IMAG(AN) + &
- REAL(BN1)*REAL(BN) + IMAG(BN1)*IMAG(BN)))
- ENDIF
-
-!*** Store previous values of AN and BN for use in computation of g=
- AN1 = AN
- BN1 = BN
-
-! FSB set up for next iteration
- PSI0 = PSI1
- PSI1 = PSI
- CHI0 = CHI1
- CHI1 = CHI
- XI1 = DCMPLX(PSI1,-CHI1)
-
- END DO ! main loop on n
-
-!*** Have summed sufficient terms.
-
-! Now compute QQSCA,QQEXT,QBACK,and GSCA
- GSCA = REAL( TWO / QSCA ) * GSCA
-
-! FSB in the following, divisions by DX * DX has been replaced by
-! multiplication by DXX1 the reciprocal of 1.0 / (DX *DX)
- QQSCA = REAL( TWO * QSCA * DXX1 )
- QQEXT = REAL( TWO * QEXT * DXX1 )
- QBACK = REAL( REAL ( 0.5d0 * XBACK * CONJG(XBACK), 8 ) * DXX1 ) ! B&H Page 122
-
- END subroutine BHMIE
-
-! ------------------------------------------------------------------
- subroutine aero_optical ( lamda_in, nmode, nr, ni, Vol, &
- dgn, sig, bext, bscat, g_bar, &
- success, modulus )
-
-! *** calculate the extinction and scattering coefficients and
-! assymetry factors for each wavelength as a sum over the
-! individual lognormal modes. Each mode may have a different
-! set of refractive indices.
-
- IMPLICIT NONE
-! *** input variables
- real, intent(in) :: lamda_in ! wavelengths [micro-m]
- INTEGER, intent(in) :: nmode ! number of lognormal modes
- real, intent(in) :: nr( nmode), ni(nmode) ! real and imaginary
- ! refractive indices
- real, intent(in) :: Vol(nmode) ! modal aerosol volumes [m**3 /m**3]
- real, intent(in) :: dgn(nmode) ! geometric mean diameters
- ! for number distribution [ m]
- real, intent(in) :: sig(nmode) ! geometric standard deviation
-
- real, intent(in), optional :: modulus(nmode) ! modulus of refracive index
-
-! *** output variables
- real, intent(out) :: bext ! extinction coefficient [ 1 / m ]
- real, intent(out) :: bscat ! scattering coefficient [ 1 / m ]
- real, intent(out) :: g_bar ! assymetry factor for Mie and molecular scattering
- logical, intent(out) :: success ! flag for successful calculation
-! *** internal variables
- INTEGER :: j ! loop index
-! real :: xlnsig(nmode) ! natural log of geometric standard deviations
- real :: beta_Sc, bsc !aerosol scattering coefficient
-
- real :: beta_Ex ! aerosol extinction coefficients
- real :: G ! modal aerosol assymetry factors
- real :: sum_g
- real :: LSIGX
- real :: lamdam1 ! 1/ lamda
- real :: alphav ! Mie size parameter
- real :: vfac
- real :: modalph
-
- real, parameter :: pi = 3.14159265359
-
- Logical, Save :: Initialize = .True.
-
-! *** coded 09/08/2004 by Dr. Francis S. Binkowski
-! FSB Modified for RRTMG version December 2009.
-! FSB modified 10/06/2004, 10/12/2004, 10/18/2005
-! FSB 01/12/2006
-! Formerly Carolina Environmental Program
-! FSB now the Institute for the Environment
-! University of North Carolina at Chapel Hill
-! email: frank_binkowski@unc.edu
-
-
-! *** initialize variables
- lamdam1 = 1.0e6 / lamda_in ! lamda now in [ m ]
- bext = 0.0
- bscat = 0.0
- sum_g = 0.0
-
- DO j = 1, nmode
-! calculate the extinction and scattering coefficients
-! for each mode
- LSIGX = log(sig(j))
-
-! calculate Mie size parameter for volume distribution
-! exp(3.0 * xlnsig*xlnsig) converts dgn to dgv (volume diameter)
- alphav = pi * dgn(j) * exp(3.0 * LSIGX * LSIGX) * lamdam1
-
- if (present(modulus)) then
- modalph = alphav * modulus(j)
- end if
-
- CALL ghintBH (nr(j), ni(j), alphav, LSIGX, beta_EX, beta_Sc, G, success)
-
-! *** ghintBH returns the normalized values
-! Calculate the actual extinction and scattering coefficients
-! by multplying by the modal volume and dividing by the wavelength
-
- vfac = Vol(j) * lamdam1
-
-! *** sum to get total extinction and scattering
-! and contribution to the overal assymetry factor
-
- bext = bext + vfac * beta_Ex ! [ 1 / m ]
- bsc = vfac * beta_Sc
- bscat = bscat + bsc
- sum_g = sum_g + bsc * G
-
- END DO ! loop on modes
-
-! *** calculate combined assymetry factor for all modes
-
- g_bar = sum_g / bscat ! changed to divide by bscat
-
- END SUBROUTINE aero_optical
-
-! ------------------------------------------------------------------
- subroutine ghintBH_1 (nr, ni, alfv, xlnsig, Qext_GH, Qscat_GH, g_gh, success)
-
-! FSB *********** This is the newest (05_30_2012) version of GhintBH
-! this version does the Mie method and calculates the optimum set of
-! set of Gauss-Hermite abscissas and weights.
-! FSB Calls Penndorf codes for alfv .le. 0.3
-
-! Dr. Francis S. Binkowski, The University of North Carolina
-! at Chapel Hill
-! FSB this code file now contains all of the necessary subroutines that
-! are called to perform an integral of the Bohren and Huffman
-! Mie codes ( as updated by Prof. Bruce C. Drain of Princeton)
-! calculates the extinction and scattering coefficients
-! normalized by wavelength and total particle volume
-! concentration for a log normal particle distribution
-! with the logarithm of the geometric standard deviation
-! given by xlnsig. The integral of the
-! asymmetry factor g is also calculated.
-! FSB Change 12/20/2011 This code now has a choice of IGH based
-! upon alfv and nr.
-! *** Does Gauss-Hermite quadrature of Qext / alfa & Qscat / alfa
-! and asymmetry factor over log normal distribution using
-! symmetric points.
-
- implicit none
-
- real, intent(in) :: nr, ni ! refractive indices
- real, intent(in) :: alfv ! Mie parameter for dgv
- real, intent(in) :: xlnsig ! log of geometric standard deviation
- real, intent(out) :: Qext_GH ! normalized extinction efficiency
- real, intent(out) :: Qscat_GH ! normalized scattering efficiency
- real, intent(out) :: g_GH ! asymmetry factor
- logical, intent(out) :: success ! flag for successful calculation
-
- real :: bext_P, bscat_P, babs_P, g_PCS, xlnsg2 ! see below for definition
-
- real :: aa1 ! see below for definition
- real :: alfaip, alfaim ! Mie parameters at abscissas
-
-! *** these are Qext/alfa and Qscat/alfv at the abscissas
- real :: qalfip_e, qalfim_e ! extinction
- real :: qalfip_s, qalfim_s ! scattering
- real :: gsalfp, gsalfm ! scattering times asymmetry factor
- integer :: IGH ! index for GH quadrature
-
-! FSB define parameters
- real, parameter :: pi = 3.14159265
- real, parameter :: sqrtpi = 1.772454
- real, parameter :: sqrtpi1 = 1.0 / sqrtpi
- real, parameter :: sqrt2 = 1.414214
- real, parameter :: three_pi_two = 3.0 * pi / 2.0
- real, parameter :: const = three_pi_two * sqrtpi1
-
- integer :: i
- complex :: crefin ! complex index of refraction
- real :: sum_e,sum_s, xi,wxi,xf
- real :: sum_sg
-
-! Gauss-Hermite abscissas and weights
-! *** the following weights and abscissas are from Abramowitz
-! Stegun, Table 25.10 page 924
-! FSB full precision from Table 25.10
-
-! FSB ten-point - IGH = 5
- real, parameter :: ghxi_10(5) = (/ 0.342901327223705, &
- 1.036610829789514, &
- 1.756683649299882, &
- 2.532731674232790, &
- 3.436159118837738 /)
-
- real, parameter :: ghwi_10(5) = (/ 6.108626337353e-01, &
- 2.401386110823e-01, &
- 3.387439445548e-02, &
- 1.343645746781e-03, &
- 7.640432855233e-06 /)
-
-! FSB six-point - IGH = 3
- real, parameter :: ghxi_6(3) = (/ 0.436077411927617, &
- 1.335849074013597, &
- 2.350604973674492 /)
-
- real, parameter :: ghwi_6(3) = (/ 7.246295952244e-01, &
- 1.570673203229e-01, &
- 4.530009905509e-03 /)
-
-! FSB two-point - IGH = 1
- real, parameter :: ghxi_2(1) = (/ 0.707106781186548 /)
-
- real, parameter :: ghwi_2(1) = (/ 8.862269254528e-01 /)
-
- real :: GHXI(5), GHWI(5) ! weight and abscissas
- integer :: NMAX ! number of weights and abscissa
-
-! FSB Check for valid range of Penndorf application.
- if ( alfv .le. 0.3) then
- xlnsg2 = xlnsig*xlnsig
- call pennfsb (nr,ni,alfv,xlnsg2,bext_P,bscat_P,babs_P,g_PCS)
- Qext_GH = bext_P
- Qscat_GH = bscat_p
- g_GH = g_PCS * exp(4.0 * xlnsg2) ! match GH integral
- else
-
-! FSB We need to do a full Mie calculation now
-! Choose IGH. These choices are designed to improve
-! the computational efficiency without sacrificing accuracy.
-
- IGH=3 ! default value; six_point is sufficient generally
-! six point
- NMAX = 3
-
- if (nr .ge. 1.7) then
-! 10 point
- IGH = 5 ! more points needed here
- NMAX = 5
- end if
-
- if ( alfv .gt. 20.0 .or. alfv .lt. 0.5 ) then
- IGH = 1 ! in this range fewer points are needed
- NMAX = 1
- end if
-
- if (IGH == 1) then
- GHXI(1) = ghxi_2(1)
- GHWI(1) = ghwi_2(1)
- else if (IGH == 3) then
- do i = 1, NMAX
- GHXI(i) = ghxi_6(i)
- GHWI(i) = ghwi_6(i)
- end do
- else
- do i = 1,NMAX
- GHXI(i) = ghxi_10(i)
- GHWI(i) = ghwi_10(i)
- end do
- end if ! set up number of abscissas and weights
-
-! FSB set complex refractive index.
- crefin= cmplx(nr,ni)
-
-! FSB now start the integration code
- aa1 = sqrt2 * xlnsig ! This 1.0 / Sqrt( A ) in derivation of the integral
- ! where A = 1.0 / ( 2.0 * xlnsg**2 )
-
-! Then alpha = alfv * exp[ u / sqrt(A) ]
-! For Gauss-Hermite Quadrature u = xi
-! Therefore, xf = exp( xi / sqrt(A) ),
-! or xf = exp( xi * aa1 )
- sum_e = 0.0
- sum_s = 0.0
- sum_sg = 0.0
-! FSB do NMAX calls to the MIE codes
- do i = 1,NMAX
- xi = GHXI(i)
- wxi = GHWI(i)
- xf = exp( xi * aa1 )
- alfaip = alfv * xf
- alfaim = alfv / xf ! division cheaper than another exp()
-! *** call subroutine to fetch the effficiencies
-
- call getqext_BH (alfaip, crefin, qalfip_e, qalfip_s, gsalfp, success)
- call getqext_BH (alfaim, crefin, qalfim_e, qalfim_s, gsalfm, success)
-
- sum_e = sum_e + wxi * ( qalfip_e + qalfim_e )
- sum_s = sum_s + wxi * ( qalfip_s + qalfim_s )
- sum_sg = sum_sg + wxi * ( gsalfp + gsalfm )
- end do
-
- g_GH = sum_sg / sum_s ! this is
- Qext_GH = const * sum_e !
- Qscat_GH = const * sum_s
- end if
-
- end subroutine ghintBH_1
-
-! ------------------------------------------------------------------
- subroutine pennfsb (n, k, xx, lnsg2, bext, bscat, babs, g)
-
-! FSB a new version of Penndorf's equations. This version does
-! analytical integration for Qext, Qscat, Qabs to generate
-! bext, bscat, babs. Note that the expressions for Qext & Qscat
-! hve been divide through by xx.
-!
-! Reference:
-! Caldas, M., V. Semiao, 2001, Radiative properties of small
-! particles: and extension of the Penndorff Model. Journal
-! of the Optical Society of America A, Vol. 18, No. 4,
-! pp 831-838.
-
-! Penndorf, R., 1962a,Scattering and extinction coefficients for small
-! absorbing and nonabsorbing aerosols,
-! J. Optical Society of America, 52, 896-904.
-
-! Penndorf, P., 1962b,Scattering and extinction coefficients for
-! small Spherical aerosols, J. Atmos. Sci., 19, p 193
-
-! FSB Coded by Dr. Francis S. Binkowski on October 25, 2011 by combining
-! two previous versions to get a common code for the Penndorf and
-! and Caldas & Semiao approaches. The Penndorf Qext, Qscat are much
-! better than the versions from Caldas & Semiao despite claims to
-! the contrary. The values of the asymmetry factor from Caldas & Semiao
-! are better than can be obtained from Penndorf.
-
-! FSB This version does the analytical integral ove a lognormal
-! size distribution.
-
- implicit none
-! input variables
- real, intent(in) :: n, k ! refractive index
- real, intent(in) :: xx ! pi * diameter / wavelength
- real, intent(in) :: lnsg2 ! log(sigma_g)**2
- real, intent(out) :: bext ! extinction coefficient
- real, intent(out) :: bscat ! scattering coefficient
- real, intent(out) :: babs ! absorption coefficient
- real, intent(out) :: g ! asmmetry factor
-
-! internal variables
- complex*16 :: m, m2,m4,m6,m21,m22
- complex*16 :: P,Q,R,S,T,U,V,W
- complex*16 :: Qprime, Rprime,Sprime,Tprime
- complex*16 :: Uprime, Vprime, Wprime
- real*8 :: Qs, gQs, gpennCS
- real*8 :: P1,P2, Q1, Q2 , S2,V1, V2 ! see usage
- real*8 :: P1SQ, P2SQ ! see usage
- real*8 :: y, y2, y3, y4, y6, y7, y8, y9
- real*8 :: x, x2, x3, x4, x6, x7, x8, x9
- real :: mag, modalf
-! FSB define useful numbers and fractions
- real, parameter :: pi = 3.14159265358979324d0
- real, parameter :: three_pi_two = 1.5d0 * pi
-
- real*8, parameter :: one = 1.0d0
- real*8, parameter :: two = 2.0d0
- real*8, parameter :: three = 3.0d0
- real*8, parameter :: four = 4.0d0
- real*8, parameter :: five = 5.0d0
- real*8, parameter :: six = 6.0d0
- real*8, parameter :: eight = 8.0d0
- real*8, parameter :: nine = 9.0d0
- real*8, parameter :: fifteen = 15.0d0
- real*8, parameter :: fortyfive = 45.0d0
-! real*8, parameter :: two5ths = two / five
- real*8, parameter :: twothrds = two / three
- real*8, parameter :: fourthirds = four / three
- real*8, parameter :: onefifteenth = one / fifteen
- real*8, parameter :: twofifteenths = two * onefifteenth
-! real*8, parameter :: fourninths = four / nine
- real*8, parameter :: eightthirds = two * fourthirds
- real*8, parameter :: one_big = one / 31500.0d0
- real*8, parameter :: two_fortyfive = two / fortyfive
- real*8, parameter :: four_225 = four / 225.0d0
- real*8, parameter :: one_210 = one / 210.0d0
-! real*8, parameter :: one_half = one / two
-! real*8, parameter :: four_two = two
- real*8, parameter :: nine_two = 4.5d0
-! real*8, parameter :: sixteen_two = eight
-! real*8, parameter :: thirtysix_two = 36.0 / two
-! real*8, parameter :: twentyfive_two = 25.0d0 / two
-! real*8, parameter :: sixtyfour_two = 64.0d0 / two
-! real*8, parameter :: fortynine_two = 49.0d0 / two
-! real*8, parameter :: eightyone_two = 81.0d0 / two
- real*8 :: A,B,C,D,E, AA,BB,CC
-
-! FSB start code
- mag = sqrt( n * n + k * k )
- modalf = mag * xx
- y = REAL( xx, 8 ) ! convert to real*8
-! FSB get powers of y
- y2 = y * y
- y3 = y2 * y
- y4 = y3 * y
- y6 = y3 * y3
- y7 = y3 * y4
- y8 = y4 * y4
- y9 = y6 * y3
-
-! FSB Calculate integrals ove the lognormal distribution
-! this is done term by term and the form is
-! xn = yn * exp( (n**2) * lnsig2 /2.0d0)
-
- x = y
- x2 = y2 * exp( two * lnsg2)
- x3 = y3 * exp( nine_two * lnsg2)
- x4 = y4 ! * exp( eight * lnsg2)
- x6 = y6 ! * exp( thirtysix_two * lnsg2)
- x7 = y7 ! * exp( fortynine_two * lnsg2)
- x8 = y8 ! * exp( fortynine_two * lnsg2)
- x9 = y9 ! * exp( eightyone_two * lnsg2)
-
-
-! FSB explicitly calculate complex refrative index m
- m = dcmplx(n,-k)
-! FSB get powers and functions of m
- m2 = m * m
- m4 = m2 * m2
- m6 = m2 * m4
- m21 = m2 - one
- m22 = m2 + two
-
-! FSB calculate Penndorf's definitions from Table II of Penndorf (1962a)
- P = m21 / m22
- Q = (m2 - two ) / m22
- S = m21 / ( two * m2 + three)
- V = m21
-! FSB get real & imaginary parts following Penndorf's mptation
- P1 = real(P)
- P2 = -aimag(P)
- P1SQ = P1 * P1
- P2SQ = P2 * P2
-
- Q1 = real(Q)
- Q2 = -aimag(Q)
- S2 = -aimag(S)
- V1 = real(V)
- v2 = -aimag(V)
-
-
-! FSB Get bext from Penndorf (1962a) Equation (7) up to x4
-! consistent with equation (8)
-! We have then divided through by x and integrated analytically
- bext = REAL( four * P2 + ( 2.4d0 * (P1 * Q2 + P2 * Q1 ) + twothrds * S2 &
- + twofifteenths * V2 ) * x2 + ( eightthirds * ( P1SQ - P2SQ ) ) * x3, 4 )
-
-! FSB get bscat from Penndorf Equation (9) up to x4
-! we have divided through by x and integrated analytically
- bscat = REAL( eightthirds * ( P1SQ + P2SQ ) * x3 )
-! FSB calculate babs
-! babs = bext - bscat
-
-! FSB now get asymmetry factor from Caldas & Semiao (2001)
-!
-! *** The following additional variables from Caldas & Semiao (2001)
-! are defined in Equations 10a to 10h.
-
- R = (m6 + 20.0d0*m4 -200.0d0*m2 + 200.0d0) / m22**2
- T = m21 / ( ( 2.0d0 * M2 + 3.0d0) **2 )
- U = m21 / (3.0d0 * M2 + 4.0d0 )
- W = m21 * ( 2.0d0 * m2 - 5.0d0)
-
-! *** further definitions from Caldas & Semiao (2001)
- Qprime = Q
- Rprime = 18.0d0 * R
- Sprime = 5.0d0 * S / P
- Tprime = 375.0d0 * T / P
-! Uprime = 28.0d0 * U / P
- Vprime = V / P
- Wprime = 5.0d0 * W / P
-
-! FSB calculate gQs and Qs from Caldas & Semiao (2001)
-! *** calculate Qs equation 13
-! Qs = eightthirds * abs(P)**2 &
-! * (x4 + onefifteenth * real(Qprime) * x6 &
-! + fourthirds * aimag(P) * x7 &
-! + one_big * ( 35.0d0 * abs(Qprime)**2 &
-! + 20.0d0 * real(Rprime) + 35.0d0 * abs(Vprime)**2 &
-! + 21.0d0 * abs(Sprime)**2 ) * x8 &
-! + two_fortyfive * aimag( Qprime * ( P - conjg(P) )) * x9 )
-
-! *** calculate gQs equation 15
-
-! gQs = four_225 * abs(P)**2 * ( &
-! (5.0d0 * Real(Vprime) + 3.0d0 * real(Sprime) ) * x6 &
-! + one_210 * ( 35.0d0 * real(Vprime*conjg(Qprime) ) &
-! + 21.0d0 * real(Sprime * conjg(Qprime) ) &
-! + 10.0d0 * real(Wprime)- 6.0d0 * real(Tprime) ) * x8 &
-! - twothrds * ( 5.0d0 * aimag(Vprime * conjg(P) ) &
-! + 3.0d0 * aimag(Sprime * conjg(P) ) ) * x9 )
-
-! FSB recast into specific terms
- A = 1.0D0 * x4
- B = onefifteenth * real(Qprime) * x6
- C = fourthirds * aimag(P) * x7
- D = one_big * ( 35.0d0 * abs(Qprime)**2 &
- + 20.0d0 * real(Rprime) + 35.0d0 * abs(Vprime)**2 &
- + 21.0d0 * abs(Sprime)**2 ) * x8
- E = two_fortyfive * aimag( Qprime * ( P - conjg(P) )) * x9
-
- Qs = eightthirds * abs(P)**2 *( A + B + C + D + E )
-
- AA = (5.0d0 * Real(Vprime) + 3.0d0 * real(Sprime) ) * x6
- BB = one_210 * ( 35.0d0 * real(Vprime*conjg(Qprime) ) &
- + 21.0d0 * real(Sprime * conjg(Qprime) ) &
- + 10.0d0 * real(Wprime)- 6.0d0 * real(Tprime) ) * x8
- CC = twothrds * ( 5.0d0 * aimag(Vprime * conjg(P) ) &
- + 3.0d0 * aimag(Sprime * conjg(P) ) ) * x9
-
- gQs = four_225 * abs(P)**2 * ( AA + BB + CC )
-
-! FSB calculate asymmetry factor and adjust with empirical term.
- g = REAL(gQs / Qs)
-! FSB now multiply by three_pi_two get output values
- bext = three_pi_two * bext
- bscat = three_pi_two * bscat
-! FSB calculate babs
- babs = bext - bscat
-
- end subroutine pennfsb
-
-! ------------------------------------------------------------------
-
-! FSB a new version of Penndorf's equations. This version does
-! analytical integration for Qext, Qscat, Qabs to generate
-! bext, bscat, babs. Note that the expressions for Qext & Qscat
-! hve been divide through by xx.
-!
-! References:
-! Penndorf, R., 1962a,Scattering and extinction coefficients for small
-! absorbing and nonabsorbing aerosols,
-! J. Optical Society of America, 52, 896-904.
-
-! Penndorf, P., 1962b,Scattering and extinction coefficients for
-! small Spherical aerosols, J. Atmos. Sci., 19, p 193
-
-! FSB Coded by Dr. Francis S. Binkowski on October 25, 2011 by combining
-! two previous versions to get a common code for the Penndorf and
-! and Caldas & Semiao approaches. The Penndorf Qext, Qscat are much
-! better than the versions from Caldas & Semiao despite claims to
-! the contrary. The values of the asymmetry factor from Caldas & Semiao
-! are better than can be obtained from Penndorf.
-! FSB Modified by FSB on 12/02/2013 to remove the Caldas & Semiao parts.
-! This version is set up to calculate LW bext and bscat so that absorption
-! in the LW can be calculated. This will work with RRTMG LW.
-! FSB This version does the analytical integral ove a lognormal
-! size distribution.
-
- subroutine pennfsbLW (crefin, xx, lnsig, bext, bscat)
-
- implicit none
-! input variables
- complex, intent(in) :: crefin !complex refractive index
- real, intent(in) :: xx ! pi * diameter / wavelength
- real, intent(in) :: lnsig ! log(sigma_g)
- real, intent(out) :: bext ! extinction coefficient
- real, intent(out) :: bscat ! scattering coefficient
-! internal variables
- real*8 :: Qext, Qscat
- real*8 :: lnsg2
-! internal variables
- complex*16 :: m, m2,m21,m22
- complex*16 :: P,Q,S,V
- real*8 :: P1,P2, Q1, Q2 , S2,V1, V2 ! see usage
- real*8 :: P1SQ, P2SQ ! see usage
- real*8 :: y, y2, y3
- real*8 :: x2, x3
-! FSB define useful numbers and fractions
- real*8, parameter :: one= 1.0d0
- real*8, parameter :: two = 2.0d0
- real*8, parameter :: three = 3.0d0
- real*8, parameter :: four = 4.0d0
- real*8, parameter :: eight = 8.0d0
- real*8, parameter :: nine = 9.0d0
- real*8, parameter :: fifteen = 15.0d0
- real*8, parameter :: twothrds = two/three
- real*8, parameter :: twofifteenths = two / fifteen
- real*8, parameter :: eightthirds = eight / three
- real*8, parameter :: nine_two = nine / two
-
-! FSB define useful numbers and fractions
- real, parameter :: pi = four*atan(one)
- real, parameter :: three_pi_two = 1.5d0 * pi
-
-! FSB start code
-
-! FSB Calculate integrals ove the lognormal distribution
-! this is done term by term; the form is
-! xn = yn * exp( (n**2) * lnsig2 /2.0d0)
- lnsg2 = lnsig * lnsig
- y = xx
- y2 = y * y
- y3 = y * y2
- x2 = y2 * exp( two * lnsg2)
- x3 = y3 * exp( nine_two * lnsg2)
-
- m= conjg(crefin) ! Penndorf asuumes k is negative.
- m2 = m * m
- m21 = m2 - one
- m22 = m2 + two
-! FSB calculate Penndorf's definitions from Table II of Penndorf (1962a)
- P = m21 / m22
- Q = (m2 - two ) / m22
- S = m21 / ( two * m2 + three)
- V = m21
-! FSB get real & imaginary parts following Penndorf's mptation
- P1 = real(P)
- P2 = -aimag(P)
- P1SQ = P1 * P1
- P2SQ = P2 * P2
-
- Q1 = real(Q)
- Q2 = -aimag(Q)
- S2 = -aimag(S)
- V1 = real(V)
- v2 = -aimag(V)
-
-! FSB Get bext from Penndorf (1962a) Equation (7) up to x4
-! consistent with equation (8)
-! We have then divided through by x and integrated analytically
- Qext = four * P2 &
- + ( 2.4d0 * (P1 * Q2 + P2 * Q1 ) + twothrds * S2 &
- + twofifteenths * V2 ) * x2 &
- + ( eightthirds * ( P1SQ - P2SQ ) ) * x3
-
-! FSB get bscat from Penndorf Equation (9) up to x4
-! we have divided through by x and integrated analytically
- Qscat = eightthirds * ( P1SQ + P2SQ ) * x3
-
-! FSB now multiply by three_pi_two get output values
- bext = three_pi_two * Qext
- bscat = three_pi_two * Qscat
-
- end subroutine pennfsbLW
-
-! ------------------------------------------------------------------
- subroutine aero_optical2( lamda_in, crefin, Vol, dgn, &
- sig, bext, bscat, gfac, success )
-
-! FSB NOTE: this subroutine calculates for single mode
-
-! *** calculate the extinction and scattering coefficients and
-! assymetry factors for each wavelength as a sum over the
-! individual lognormal modes. Each mode may have a different
-! set of refractive indices.
-
- IMPLICIT NONE
-
-! *** input variables
- real, intent(in) :: lamda_in ! wavelengths [micro-m]
- complex, intent(in) :: crefin ! Complex refractive index
- real, intent(in) :: Vol ! modal aerosol volumes [m**3 /m**3]
- real, intent(in) :: dgn ! geometric mean diameters
- ! for number distribution [ m]
- real, intent(in) :: sig ! geometric standard deviation
-
-! *** output variables
- real, intent(out) :: bext ! extinction coefficient [ 1 / m ]
- real, intent(out) :: bscat ! scattering coefficient [ 1 / m ]
- real, intent(out) :: gfac ! assymetry factor for Mie and molecular scattering
- logical, intent(out) :: success ! flag for successful calculation
-
-! *** internal variables
-! real :: xlnsig(nmode) ! natural log of geometric standard deviations
- real :: beta_Sc ! aerosol scattering coefficient
-
- real :: beta_Ex ! aerosol extinction coefficients
- real :: G ! modal aerosol assymetry factors
- real :: sum_g
- real :: LSIGX
- real :: lamdam1 ! 1/ lamda
- real :: alphav ! Mie size parameter
- real :: vfac
- real, parameter :: pi = 3.14159265359
-
- Logical, Save :: Initialize = .True.
-
-! FSB coded 04/15/2012 by Dr. Francis S. Binkowski
-! modified from an earlier version
-! Center for Environmental Modeling for PolicyDevelopment
-! Institute for the Environment
-! University of North Carolina at Chapel Hill
-! email: frank_binkowski@unc.edu
-
-! *** initialize variables
- lamdam1 = 1.0e6 / lamda_in ! lamda now in [ m ]
- bext = 0.0
- bscat = 0.0
- sum_g = 0.0
- LSIGX = log(sig)
-
-! calculate Mie size parameter for volume distribution
-! exp(3.0 * xlnsig*xlnsig) converts dgn to dgv (volume diameter)
- alphav = pi * dgn * exp(3.0 * LSIGX * LSIGX) * lamdam1
-
- If(Initialize .And. AERO_UTIL_LOG .GT. 0 )Then
- If( Use_Odd_Quadrature )then
- write(AERO_UTIL_LOG,99501)Quadrature_Points
- else
- write(AERO_UTIL_LOG,99504)
- Initialize = .False.
- End If
- End If
-
- If( Use_Odd_Quadrature )then
- CALL ghintBH (Initialize, crefin, alphav, LSIGX, beta_EX, beta_Sc, G, success)
- Else
- CALL ghintBH (crefin, alphav, LSIGX, beta_EX, beta_Sc, G, success)
- End If
-
-! *** ghintBH returns the normalized values
-! Calculate the actual extinction and scattering coefficients
-! by multplying by the modal volume and dividing by the wavelength
-
- vfac = Vol * lamdam1
- bext = vfac * beta_Ex ! [ 1 / m ]
- bscat = vfac * beta_Sc ! [ 1 / m ]
- gfac = G
-99501 Format(I2,' Quadrature Points for Volume Averaged Aerosol Optics')
-99504 Format('Even Number Quadrature Points for Volume Averaged Aerosol Optics')
-
- END SUBROUTINE aero_optical2
-
-! ------------------------------------------------------------------
- subroutine aero_optical_CS ( lamda_in, refcor,refshell, VOLCOR, &
- VOLSHELL, DGNCOR, DGNSHELL, SIG, &
- bext, bscat, gfac, succesS )
-
-! FSB NOTE: values for one mode are returend
-! *** calculate the extinction and scattering coefficients and
-! assymetry factors for each wavelength as a sum over the
-! individual lognormal modes. Each mode may have a different
-! set of refractive indices.
-
- IMPLICIT NONE
-! *** input variables
- real,intent(in) :: lamda_in ! wavelengths [micro-m]
- complex,intent(in) :: refcor ! Complex refractive index -core
- complex,intent(in) :: refshell ! Complex refractive index -shell
- real,intent(in) :: VOLCOR ! volume of core
- real,intent(in) :: VOLSHELL ! volume of shell
- real,intent(in) :: DGNCOR ! geometric mean diameters
- ! for number distribution [m]
- real,intent(in) :: DGNSHELL ! geometric mean diameters
- ! for number distribution [m]
- real,intent(in) :: SIG ! geometric standard deviation
-
-! *** output variables
- real,intent(out) :: bext ! extinction coefficient [ 1 / m ]
- real,intent(out) :: bscat ! scattering coefficient [ 1 / m ]
- real,intent(out) :: gfac ! assymetry factor
- logical, intent(OUT) :: success ! flag for successful calculation
-
-! *** internal variables
-! real :: xlnsig(nmode) ! natural log of geometric standard deviations
- real :: beta_Sc ! aerosol scattering coefficient
-
- real :: beta_Ex ! aerosol extinction coefficients
- real :: G ! modal aerosol assymetry factors
- real :: LSIGX
- real :: XX, YY ! Mie size parameter
- real :: expfac
- real :: lamdam1 ! 1/ lamda
- real :: vfac
-
- Logical, Save :: Initialize = .True.
-
- real, parameter :: pi = 3.14159265359
-
-! FSB coded 04/15/2012 by Dr. Francis S. Binkowski
-! modified from an earlier version
-! Center for Environmental Modeling for PolicyDevelopment
-! Institute for the Environment
-! University of North Carolina at Chapel Hill
-! email: frank_binkowski@unc.edu
-
-
-! *** initialize variables
- lamdam1 = 1.0e6 / lamda_in ! lamda now in [ m ]
-
-! calculate the extinction and scattering coefficients
- LSIGX = log(SIG)
- expfac = pi * exp(3.0 * LSIGX * LSIGX) * lamdam1
-
-! calculate Mie size parameter for volume distribution
-! exp(3.0 * xlnsig*xlnsig) converts dgn to dgv (volume diameter)
- XX = DGNCOR * expfac
- YY = DGNSHELL * expfac
-
- If(Initialize .And. AERO_UTIL_LOG .GT. 0 )Then
- If( Use_Odd_Quadrature )then
- write(AERO_UTIL_LOG,99500)Quadrature_Points
- else
- write(AERO_UTIL_LOG,99502)
- Initialize = .False.
- End If
- End If
-
- If( Use_Odd_Quadrature )then
- CALL ghintBH_CS(Initialize,refcor,refshell,XX,YY,LSIGX,beta_EX,beta_Sc,G, success)
- Else
- CALL ghintBH_CS(refcor,refshell,XX,YY,LSIGX,beta_EX,beta_Sc,G, success)
- End If
-
-! FSB ghintBH_CS returns the normalized values
-! Calculate the actual extinction and scattering coefficients
-! by multplying by the modal volume and dividing by the wavelength.
-! For the coated-sphere (core-shell) calculation use the combined
-! volume
-
- vfac = (VOLCOR + VOLSHELL) * lamdam1
- bext = vfac * beta_Ex ! [ 1 / m ]
- bscat = vfac * beta_Sc ! [ 1 / m ]
- gfac = G
-99500 Format(I2,' Quadrature Points for Core-Shell Aerosol Optics')
-99502 Format('Even Number Quadrature Points for Core-Shell Aerosol Optics')
-
- END SUBROUTINE aero_optical_CS
-
-! ------------------------------------------------------------------
-
- subroutine aero_optical_LW (lamda_in, crefin, Vol, &
- dgn, sig, bext, bscat )
-
-! *** calculate the extinction and scattering coefficients and
-! asymmetry factor for LW radiation.
-! The calling code only uses
-
- IMPLICIT NONE
-! *** input variables
- real, intent(in) :: lamda_in ! wavelengths [micro-m]
-
- complex, intent(in) :: crefin ! complex refractive index
- real, intent(in) :: Vol ! modal aerosol volumes [m**3 /m**3]
- real, intent(in) :: dgn ! geometric mean diameter
- ! for number distribution [ m]
- real, intent(in) :: sig ! geometric standard deviation
-
-
-! *** output variables
- real, intent(out) :: bext ! extinction coefficient [ 1 / m ]
- real, intent(out) :: bscat ! scattering coefficient [ 1 / m ]
-
-
-! *** internal variables
- real, parameter :: pi = 3.14159265359
-
- real :: lamda ! wavelength [ m]
- real :: beta_Sc ! aerosol scattering coefficient
-
- real :: beta_Ex ! aerosol extinction coefficients
- real :: G ! modal aerosol assymetry factors
- real :: VLX, DGX, SIGX, LSIGX
- real :: lamdam1 ! 1/ lamda
- real :: alphav ! Mie size parameter
- real vfac
-
- logical :: success
-
-! *** coded 09/08/2004 by Dr. Francis S. Binkowski
-! FSB Modified for RRTMG version December 2009.
-! FSB modified 10/06/2004, 10/12/2004, 10/18/2005
-! FSB 01/12/2006
-! FSB 12/02/2013
-! FSB Institute for the Environment
-! University of North Carolina at Chapel Hill
-! email: frank_binkowski@unc.edu
-
-! FSB Start Code:
-! *** initialize variables
-! lamda = 1.0e-6 * lamda_in ! lamda now in [ m ]
- bext = 0.0
- bscat = 0.0
-
-! lamdam1 = 1.0 / lamda ! 1 / [m]
- lamdam1 = 1.0e6 / lamda_in ! 1 / [m]
-
- VLX = Vol
- DGX = dgn
- SIGX = sig
- LSIGX = log(SIGX)
-
-! calculate Mie size parameter for volume distribution
-! exp(3.0 * xlnsig*xlnsig) converts dgn to dgv (volume diameter)
- alphav = pi * DGX * exp(3.0 * LSIGX * LSIGX) * lamdam1
- vfac = VLX * lamdam1
-
- ! FSB Check for valid range of Penndorf application.
- if ( alphav .le. 0.3) then
- call pennfsbLW(crefin, alphav, LSIGX, beta_EX, beta_Sc)
- G = 0.0
- else
- CALL ghintBH(crefin, alphav, LSIGX, beta_EX, beta_Sc, G, success)
- end if
-
- bext = vfac * beta_Ex ! [ 1 / m ]
- bscat = vfac * beta_Sc
-
- END SUBROUTINE aero_optical_LW
-
-! ------------------------------------------------------------------
- subroutine ghintBH_2 (crefin,alfv,xlnsig,Qext_GH,Qscat_GH,g_gh, success)
-
-! *************** REVISED VERSION < NOTE
-! FSB *********** This is the newest (04_14_2012) version of GhintBH
-! this version does the Mie method and calculates the optimum set of
-! set of Gauss-Hermite abscissas and weights.
-! Dr. Francis S. Binkowski, The University of North Carolina
-! at Chapel Hill
-! FSB this code file now contains all of the necessary subroutines that
-! are called to perform an integral of the Bohren and Huffman
-! Mie codes ( as updated by Prof. Bruce C. Drain of Princeton)
-! calculates the extinction and scattering coefficients
-! normalized by wavelength and total particle volume
-! concentration for a log normal particle distribution
-! with the logarithm of the geometric standard deviation
-! given by xlnsig. The integral of the
-! asymmetry factor g is also calculated.
-! FSB Change 12/20/2011 This code now has a choice of IGH based
-! upon alfv and nr.
-! FBB Changes Simplified code. Eliminated Penndorf code
-! *** Does Gauss-Hermite quadrature of Qext / alfa & Qscat / alfa
-! and asymmetry factor over log normal distribution using
-! symmetric points.
-!
- implicit none
-
- complex, intent(in) :: crefin ! complex index of refraction
- real, intent(in) :: alfv ! Mie parameter for dgv
- real, intent(in) :: xlnsig ! log of geometric standard deviation
- real, intent(out) :: Qext_GH ! normalized extinction efficiency
- real, intent(out) :: Qscat_GH ! normalized scattering efficiency
- real, intent(out) :: g_GH ! asymmetry factor
- logical, intent(out) :: success ! flag for successful calculation
-
- real :: nr ! real part of refractive index
- real :: aa1 ! see below for definition
- real :: alfaip, alfaim ! Mie parameters at abscissas
-
-! *** these are Qext/alfa and Qscat/alfv at the abscissas
- real :: qalfip_e, qalfim_e ! extinction
- real :: qalfip_s, qalfim_s ! scattering
- real :: gsalfp, gsalfm ! scattering times asymmetry factor
- integer :: IGH ! index for GH quadrature
-
-! FSB define parameters
- real, parameter :: pi = 3.14159265
- real, parameter :: sqrtpi = 1.772454
- real, parameter :: sqrtpi1 = 1.0 / sqrtpi
- real, parameter :: sqrt2 = 1.414214
- real, parameter :: three_pi_two = 3.0 * pi / 2.0
- real, parameter :: const = three_pi_two * sqrtpi1
-
- integer :: i
- real :: sum_e,sum_s, xi,wxi,xf
- real :: sum_sg
-
-! Gauss-Hermite abscissas and weights
-! *** the following weights and abscissas are from Abramowitz
-! Stegun, Table 25.10 page 924
-! FSB full precision from Table 25.10
-
-! FSB ten-point - IGH = 5
- real, parameter :: ghxi_10(5) = (/ 0.342901327223705, &
- 1.036610829789514, &
- 1.756683649299882, &
- 2.532731674232790, &
- 3.436159118837738 /)
-
- real, parameter :: ghwi_10(5) = (/ 6.108626337353e-01, &
- 2.401386110823e-01, &
- 3.387439445548e-02, &
- 1.343645746781e-03, &
- 7.640432855233e-06 /)
-
-! FSB six-point - IGH = 3
- real, parameter :: ghxi_6(3) = (/ 0.436077411927617, &
- 1.335849074013597, &
- 2.350604973674492 /)
-
- real, parameter :: ghwi_6(3) = (/ 7.246295952244e-01, &
- 1.570673203229e-01, &
- 4.530009905509e-03 /)
-
-! FSB two-point - IGH = 1
- real, parameter :: ghxi_2(1) = (/ 0.707106781186548 /)
-
- real, parameter :: ghwi_2(1) = (/ 8.862269254528e-01 /)
-
- real :: GHXI(5), GHWI(5) ! weight and abscissas
- integer :: NMAX ! number of weights and abscissa
-
-
-! start code
-! FSB now choose IGH. These choices are designed to improve
-! the computational efficiency without sacrificing accuracy.
-
- nr = real(crefin)
-
- IGH=3 ! default value; six_point is sufficient generally
-! six point
- NMAX = 3
-
- if (nr .ge. 1.7) then
-! 10 point
- IGH = 5 ! more points needed here
- NMAX = 5
- end if
-
- if( alfv .gt. 20.0 .or. alfv .lt. 0.5 ) then
- IGH = 1 ! in this range fewer points are needed
- NMAX = 1
- end if
-
- if (IGH == 1) then
-! two point
- GHXI(1) = ghxi_2(1)
- GHWI(1) = ghwi_2(1)
- else if (IGH == 3) then
- do i = 1, NMAX
- GHXI(i) = ghxi_6(i)
- GHWI(i) = ghwi_6(i)
- end do
- else
- do i = 1,NMAX
- GHXI(i) = ghxi_10(i)
- GHWI(i) = ghwi_10(i)
- end do
- end if ! set up number of abscissas and weights
-
-! FSB now start the integration code
- aa1 = sqrt2 * xlnsig ! This 1.0 / Sqrt( A ) in derivation of the integral
- ! where A = 1.0 / ( 2.0 * xlnsg**2 )
-
-! Then alpha = alfv * exp[ u / sqrt(A) ]
-! For Gauss-Hermite Quadrature u = xi
-! Therefore, xf = exp( xi / sqrt(A) ),
-! or xf = exp( xi * aa1 )
-
- sum_e = 0.0
- sum_s = 0.0
- sum_sg = 0.0
-! FSB do NMAX calls to the MIE codes
- do i = 1,NMAX
- xi = GHXI(i)
- wxi = GHWI(i)
- xf = exp( xi * aa1 )
- alfaip = alfv * xf
- alfaim = alfv / xf ! division cheaper than another exp()
-! *** call subroutine to fetch the effficiencies
-
- call getqext_BH(alfaip,crefin,qalfip_e,qalfip_s, gsalfp, success)
- call getqext_BH(alfaim,crefin,qalfim_e,qalfim_s, gsalfm, success)
-
- sum_e = sum_e + wxi * ( qalfip_e + qalfim_e )
- sum_s = sum_s + wxi * ( qalfip_s + qalfim_s )
- sum_sg = sum_sg + wxi * ( gsalfp + gsalfm )
-
- end do
-
- g_GH = sum_sg / sum_s ! this is
- Qext_GH = const * sum_e !
- Qscat_GH = const * sum_s
-
- end subroutine ghintBH_2
-
-! ------------------------------------------------------------------
- subroutine ghintBH_CS_even (RCORE, RSHELL , XX, YY, xlnsig, &
- Qext_GH,Qscat_GH, g_gh, success)
-
-! FSB code for coated-sphere (core-shell) version
-
-! *************** REVISED VERSION < NOTE
-! FSB *********** This is the newest (04_14_2012) version of ghintBH_CS
-! for the coated-sphere (core-shell) method using BHCOAT
-! this version does the Mie method and calculates the optimum set of
-! set of Gauss-Hermite abscissas and weights.
-! Dr. Francis S. Binkowski, The University of North Carolina
-! at Chapel Hill
-
-! FSB this code file now contains all of the necessary subroutines that
-! are called to perform an integral of the Bohren and Huffman
-! Mie codes ( as updated by Prof. Bruce C. Drain of Princeton)
-! calculates the extinction and scattering coefficients
-! normalized by wavelength and total particle volume
-! concentration for a log normal particle distribution
-! with the logarithm of the geometric standard deviation
-! given by xlnsig. The integral of the
-! asymmetry factor g is also calculated.
-! FSB Change 12/20/2011 This code now has a choice of IGH based
-! upon alfv and nr.
-! FBB Changes Simplified code. Eliminated Penndorf code
-! *** Does Gauss-Hermite quadrature of Qext / alfa & Qscat / alfa
-! and asymmetry factor over log normal distribution using
-! symmetric points.
-!
- implicit none
- complex, intent(in) :: RCORE ! refractive index of core
- complex, intent(in) :: RSHELL ! refractive index of shell
- real, intent(in) :: XX ! Mie parameter for core
- real, intent(in) :: YY ! Mie parameter for shell
- real, intent(in) :: xlnsig ! log of geometric standard deviation
- real, intent(out) :: Qext_GH ! normalized extinction efficiency
- real, intent(out) :: Qscat_GH ! normalized scattering efficiency
- real, intent(out) :: g_GH ! asymmetry factor
- logical, intent(out) :: success ! flag for successful calculation
-
- real :: nr ! real part of refractive index
- real :: aa1 ! see below for definition
- real :: XXP, XXM ! Mie parameters at abscissas - CORE
- real :: YYP, YYM ! Mie parameters at abscissas - SHELL
-
-! FSB define parameters
- real, parameter :: pi = 3.14159265
- real, parameter :: sqrtpi = 1.772454
- real, parameter :: sqrtpi1 = 1.0 / sqrtpi
- real, parameter :: sqrt2 = 1.414214
- real, parameter :: three_pi_two = 3.0 * pi / 2.0
- real, parameter :: const = three_pi_two * sqrtpi1
-
-! *** these are Qext/alfa and Qscat/alfv at the abscissas
- real :: qalfip_e, qalfim_e ! extinction
- real :: qalfip_s, qalfim_s ! scattering
- real :: gsalfp, gsalfm ! scattering times asymmetry factor
- integer :: IGH ! index for GH quadrature
- integer :: i
- real :: sum_e,sum_s, xi,wxi,xf, temp
- real :: sum_sg
-
-! Gauss-Hermite abscissas and weights
-! *** the following weights and abscissas are from Abramowitz
-! Stegun, Table 25.10 page 924
-! FSB full precision from Table 25.10
-
-! FSB ten-point - IGH = 5
- real, parameter :: ghxi_10(5) = (/ 0.342901327223705, &
- 1.036610829789514, &
- 1.756683649299882, &
- 2.532731674232790, &
- 3.436159118837738 /)
-
- real, parameter :: ghwi_10(5) = (/ 6.108626337353e-01, &
- 2.401386110823e-01, &
- 3.387439445548e-02, &
- 1.343645746781e-03, &
- 7.640432855233e-06 /)
-
-! FSB six-point - IGH = 3
- real, parameter :: ghxi_6(3) = (/ 0.436077411927617, &
- 1.335849074013597, &
- 2.350604973674492 /)
-
- real, parameter :: ghwi_6(3) = (/ 7.246295952244e-01, &
- 1.570673203229e-01, &
- 4.530009905509e-03 /)
-
-! FSB two-point - IGH = 1
- real, parameter :: ghxi_2(1) = (/ 0.707106781186548 /)
-
- real, parameter :: ghwi_2(1) = (/ 8.862269254528e-01 /)
-
- real GHXI(5), GHWI(5) ! weight and abscissas
- integer NMAX ! number of weights and abscissa
-
-! start code
-! FSB now choose IGH. These choices are designed to improve
-! the computational efficiency without sacrificing accuracy.
-
- nr = real(RSHELL)
-
- IGH=3 ! default value; six_point is sufficient generally
-! six point
- NMAX = 3
-
- if (nr .ge. 1.7) then
-! 10 point
- IGH = 5 ! more points needed here
- NMAX = 5
- end if
-
- if ( XX .gt. 20.0 .or. XX .lt. 0.5 ) then
- IGH = 1 ! in this range fewer points are needed
- NMAX = 1
- end if
-
- if (IGH == 1) then
-! two point
- GHXI(1) = ghxi_2(1)
- GHWI(1) = ghwi_2(1)
- else if (IGH == 3) then
- do i = 1, NMAX
- GHXI(i) = ghxi_6(i)
- GHWI(i) = ghwi_6(i)
- end do
- else
- do i = 1,NMAX
- GHXI(i) = ghxi_10(i)
- GHWI(i) = ghwi_10(i)
- end do
- end if ! set up number of abscissas and weights
-
-! FSB now start the integration code
- aa1 = sqrt2 * xlnsig ! This 1.0 / Sqrt( A ) in derivation of the integral
- ! where A = 1.0 / ( 2.0 * xlnsg**2 )
-
-! Then alpha = alfv * exp[ u / sqrt(A) ]
-! For Gauss-Hermite Quadrature u = xi
-! Therefore, xf = exp( xi / sqrt(A) ),
-! or xf = exp( xi * aa1 )
- sum_e = 0.0
- sum_s = 0.0
- sum_sg = 0.0
-! FSB do NMAX calls to the MIE codes
- do i = 1,NMAX
- xi = GHXI(i)
- wxi = GHWI(i)
- xf = exp( xi * aa1 )
- temp = 1.0 / xf
- XXP = XX * xf
- XXM = XX * temp ! division cheaper than another exp()
- YYP = YY * xf
- YYM = YY * temp ! division cheaper than another exp()
-! *** call subroutine to fetch the effficiencies
-
- call getqsgBHCS(XXP,YYP,RCORE,RSHELL,qalfip_e,qalfip_s,gsalfp, success)
- call getqsgBHCS(XXM,YYM,RCORE,RSHELL,qalfim_e,qalfim_s,gsalfm, success)
-
- sum_e = sum_e + wxi * ( qalfip_e + qalfim_e )
- sum_s = sum_s + wxi * ( qalfip_s + qalfim_s )
- sum_sg = sum_sg + wxi * ( gsalfp + gsalfm )
- end do
-
- g_GH = sum_sg / sum_s ! this is
- Qext_GH = const * sum_e !
- Qscat_GH = const * sum_s
-
- end subroutine ghintBH_CS_even
-
-! ------------------------------------------------------------------
- subroutine getqsgBHCS (XX,YY,RRFRL1,RRFRL2,qxtalf,qscalf,qsgalf, success)
- implicit none
-
- real, intent(in) :: XX, YY
- real, intent(out) :: qxtalf, qscalf, qsgalf
- complex, intent(in) :: RRFRL1,RRFRL2 ! refractive indices Core , Shell
- logical, intent(out) :: success ! flag for successful calculation
-
- real :: QEXT, QSCA, QBACK, G_MIE
- real :: xx1
- character (len = 20) :: mystr1, mystr2, mystr3, mystr4
-
- xx1 = 1.0 / YY
-
-! if ( (xx * real(RRFRL1) >= 30.0) &
-! .or. (xx * aimag(RRFRL1) >= 30.0) &
-! .or. (yy * aimag(RRFRL2) >= 30.0)) then
-! print *, ' ==d== bhcoat error'
-! end if
-
- call BHCOAT (XX,YY,RRFRL1,RRFRL2,QEXT,QSCA,QBACK,G_MIE, SUCCESS)
-
-! if ((trim(mystr1) == ' NaN') .or. &
-! (trim(mystr2) == ' NaN') .or. &
-! (trim(mystr3) == ' NaN') .or. &
-! (trim(mystr4) == ' NaN')) then
-! call BHCOAT (XX,YY,RRFRL1,RRFRL2,QEXT,QSCA,QBACK,G_MIE)
-! end if
-
- qxtalf = QEXT * xx1
- qscalf = QSCA * xx1
- qsgalf = qscalf * G_MIE
-
- END subroutine getqsgBHCS
-
-! ------------------------------------------------------------------
- SUBROUTINE BHCOAT (XX, YY, RRFRL1, RRFRL2, QQEXT, QQSCA, QBACK, GGSCA, SUCCESS)
-
- use complex_number_module
-
- implicit none ! added by FSB
-
-! Arguments:
- real, intent(in) :: XX,YY ! Defined below
- complex, intent(in) :: RRFRL1,RRFRL2 ! Defined below
- real, intent(out) :: QQEXT,QQSCA,QBACK ! Defined below
- real, intent(out) :: GGSCA ! asymmetry factor added by FSB
- logical,intent(out) :: success
-
-! Local variables:
-
- real*8, parameter :: DEL = 1.0D-08
- real*8, parameter :: ONE = 1.0D0, TWO = 2.0D0
-! complex*16, save :: II
-! data II/(0.D0,1.D0)/
- type(complex_number) :: II
-
- integer :: IFLAG,N,NSTOP
-
- character (len = 128) :: mystr
-
-! -----------------------------------------------------------
-! del is the inner sphere convergence criterion
-! -----------------------------------------------------------
-
- real*8 :: CHI0Y,CHI1Y,CHIY,PSI0Y,PSI1Y,PSIY,QEXT,RN,QSCA,X,Y,YSTOP,GSCA
- real*8 :: TWO_N_M_ONE, TWO_N_P_ONE
- real*8 :: RY, RYY, RNRY, RN1, factor
-
-! complex*16 :: AMESS1,AMESS2,AMESS3,AMESS4,AN,ANCAP,AN1, BN,BNCAP,BN1, BRACK, &
- type(complex_number) :: AMESS1,AMESS2,AMESS3,AMESS4,AN,ANCAP,AN1, BN,BNCAP,BN1, BRACK, &
- CHI0X2,CHI0Y2,CHI1X2,CHI1Y2,CHIX2,CHIPX2,CHIPY2,CHIY2,CRACK, &
- D0X1,D0X2,D0Y2,D1X1,D1X2,D1Y2,DNBAR,GNBAR, &
- REFREL,RFREL1,RFREL2, XBACK,XI0Y,XI1Y,XIY, &
- X1,X2,Y2,RCX1, RCX2,RCY2, FAC1, FAC2
-
-!***********************************************************************
-! NOTES from Prof. Bruce T. Draine, Princeton University
-! Subroutine BHCOAT calculates Q_ext, Q_sca, Q_back for coated sphere.
-! All bessel functions computed by upward recurrence.
-! Input:
-! XX = 2*PI*RCORE*REFMED/WAVEL
-! YY = 2*PI*RMANT*REFMED/WAVEL
-! RFREL1 = REFCOR/REFMED
-! RFREL2 = REFMAN/REFMED
-! where REFCOR = complex refr.index of core)
-! REFMAN = complex refr.index of mantle)
-! REFMED = real refr.index of medium)
-! RCORE = radius of core
-! RMANT = radius of mantle
-! WAVEL = wavelength of light in ambient medium
-!
-! Routine BHCOAT is taken from Bohren & Huffman (1983)
-! Obtained from C.L.Joseph
-!
-! History:
-! 92/11/24 (BTD) Explicit declaration of all variables
-! April 30,2012 (FSB) added additional code to optimize
-! run time by finding common terms and replacing multiple
-! divisions by multiplication by a reciprocal.
-! April 09, 2012 code transferred from BTD's BMHMIE to
-! calculate the asymmetry factor by Prof. Francis S. Binkowski of
-! The University of North Carolina at Chapel Hill.
-! April 30,2012 (FSB) added additional code to optimize
-! run time by finding common terms and replacing multiple
-! divisions by multiplication by a reciprocal.
-! July 16, 2010 more optimization by Dr. David Wong (DW) at US EPA
-
-! REFERENCE:
-! Bohren, Craig F. and Donald R. Huffman, Absorption and
-! Scattering of Light by Small Particles, Wiley-Interscience
-! copyright 1983. Paperback Published 1998.
-! This code was originally listed in Appendix B. pp 483-489.
-! As noted above , the original code was subsequently
-! modified by Prof. Bruce T. Draine of Princeton University.
-!
-! FSB The background for this code is discussed in Borhen & Huffman (1983)
-! on pages 181-183 ( Equations 8.2 ) and on pages 483-484.
-!***********************************************************************
-!
-! Start Code
-
- SUCCESS = .TRUE.
-
- II = c_set(0.0D0, 1.0D0)
-
-! this technique will make the second 4 byte in the 8 byte variable be 0
-! rather than arbitrary digits to increase accuracy
- write (mystr, *) xx, yy, real(RRFRL1), aimag(RRFRL1), real(RRFRL2), aimag(RRFRL2)
- read (mystr, *) x, y, RFREL1, RFREL2
-
-! X = XX
-! Y = YY
- RY = ONE / Y
- RYY = RY * RY
-! RFREL1%real_part = real(RRFRL1)
-! RFREL1%imag_part = aimag(RRFRL1)
-! RFREL2%real_part = real(RRFRL2)
-! RFREL2%imag_part = aimag(RRFRL2)
- x1 = c_mul(x, rfrel1)
- x2 = c_mul(x, rfrel2)
- y2 = c_mul(y, rfrel2)
- RCX1 = c_div(ONE, X1)
- RCX2 = c_div(ONE, X2)
- RCY2 = c_div(ONE, Y2)
- refrel = c_div(rfrel2, rfrel1)
- ystop = y + 4.0 * y**0.3333 + 2.0
- nstop = INT( ystop )
-
-! -----------------------------------------------------------
-! series terminated after nstop terms
-! -----------------------------------------------------------
-
-! initialize variables
- d0x1 = c_div(c_cos(x1), c_sin(x1))
- d0x2 = c_div(c_cos(x2), c_sin(x2))
- d0y2 = c_div(c_cos(y2), c_sin(y2))
-
- psi0y = cos(y)
- psi1y = sin(y)
- chi0y = -sin(y)
- chi1y = cos(y)
-
- xi0y = c_sub(psi0y, c_mul(chi0y, II))
- xi1y = c_sub(psi1y, c_mul(chi1y, II))
-
- chi0y2 = c_mul(-1.0d0, c_SIN(y2))
- chi1y2 = c_COS(y2)
- chi0x2 = c_mul(-1.0d0, c_SIN(x2))
- chi1x2 = c_COS(x2)
- qsca = 0.0d0
- qext = 0.0d0
- GSCA = 0.0d0
- xback = c_set(0.0d0, 0.0d0)
- iflag = 0
- factor = 1.0d0
-
-! FSB Start main loop
- DO n = 1, nstop
- rn = REAL( n, 8 )
- RN1 = ONE / RN
- TWO_N_M_ONE = TWO * RN - ONE
- TWO_N_P_ONE = TWO * RN + ONE
- psiy = (TWO_N_M_ONE)*psi1y*RY - psi0y
- chiy = (TWO_N_M_ONE)*chi1y*RY - chi0y
- xiy = c_sub(psiy, c_mul(chiy, II))
- d1y2 = c_sub(c_div(ONE, c_sub(c_mul(rn, RCY2), d0y2)), c_mul(rn, RCY2))
-
- IF (iflag .eq. 0) THEN
-! *** Calculate inner sphere ancap, bncap
-! and brack and crack
- d1x1 = c_sub(c_div(ONE, c_sub(c_mul(rn, RCX1), d0x1)), c_mul(rn, RCX1))
- d1x2 = c_sub(c_div(ONE, c_sub(c_mul(rn, RCX2), d0x2)), c_mul(rn, RCX2))
-
- chix2 = c_sub(c_mul(c_mul(TWO*rn - ONE, chi1x2), RCX2), chi0x2)
- chiy2 = c_sub(c_mul(c_mul(TWO*rn - ONE, chi1y2), RCY2), chi0y2)
-
- chipx2 = c_sub(chi1x2, c_mul(c_mul(rn, chix2), RCX2))
- chipy2 = c_sub(chi1y2, c_mul(c_mul(rn, chiy2), RCY2))
-
- ANCAP = c_sub(c_mul(c_mul(REFREL, D1X1), CHIX2), CHIPX2)
- ANCAP = c_mul(ANCAP, c_sub(c_mul(CHIX2, D1X2), CHIPX2))
- ANCAP = c_div(c_sub(c_mul(REFREL, D1X1), D1X2), ANCAP)
-
- brack = c_mul(ancap, c_sub(c_mul(chiy2, d1y2), chipy2))
-
- bncap = c_sub(c_mul(refrel, d1x2), d1x1)
- bncap = c_div(bncap, c_sub(c_mul(refrel, chipx2), c_mul(d1x1, chix2)))
- bncap = c_div(bncap, c_sub(c_mul(chix2, d1x2), chipx2))
-
- crack = c_mul(bncap, c_sub(c_mul(chiy2, d1y2), chipy2))
-! *** calculate convergence test expressions
-! for inner sphere.
-! *** see pages 483-485 of Bohren & Huffman for
-! definitions.
- amess1 = c_mul(brack, chipy2)
- amess2 = c_mul(brack, chiy2)
- amess3 = c_mul(crack, chipy2)
- amess4 = c_mul(crack, chiy2)
-
-! Now test for convergence for inner sphere
-! All four criteria must be satisfied. See page 484 of B & H
- IF (c_ABS(amess1) .LE. del*c_ABS(d1y2) .AND. &
- (c_ABS(amess2) .LE. del) .AND. &
- (c_ABS(amess3) .LE. del*c_ABS(d1y2)) .AND. &
- (c_ABS(amess4) .LE. del) ) THEN
-! convergence for inner sphere
- brack = c_set(0.0D0,0.0D0)
- crack = c_set(0.0D0,0.0D0)
- iflag = 1
-! ELSE
-! no convergence yet
-! iflag = 0
- END IF
- END IF ! test on iflag .eq. 0
-
-! *** note usage of brack and crack See equations on
-! Page 485 and discussion on pages 486 -487 of B & H
- dnbar = c_sub(d1y2, c_mul(brack, chipy2))
- dnbar = c_div(dnbar, c_sub(ONE, c_mul(brack, chiy2)))
- gnbar = c_sub(d1y2, c_mul(crack, chipy2))
- gnbar = c_div(gnbar, c_sub(ONE, c_mul(crack, chiy2)))
-!*** Store previous values of an and bn for use
-! in computation of g=
- IF (N .GT. 1) THEN
- AN1 = an
- BN1 = bn
- END IF
-! *** update an and bn
- RNRY = rn * RY
- FAC1 = c_add(c_div(dnbar, rfrel2), RNRY)
-
- an = c_sub(c_mul(psiy, FAC1), psi1y)
- an = c_div(an, c_sub(c_mul(FAC1, xiy), xi1y))
- FAC2 = c_add(c_mul(rfrel2, gnbar), RNRY)
- bn = c_sub(c_mul(psiy, FAC2), psi1y)
- bn = c_div(bn, c_sub(c_mul(FAC2, xiy), xi1y))
-
-! *** Calculate sums for qsca, qext, xback
- qsca = qsca + (TWO_N_P_ONE) * (c_ABS(an)**2 + c_ABS(bn)**2)
-
- qext = qext + TWO_N_P_ONE * (an%real_part + bn%real_part)
-
- FACTOR = FACTOR * (-1.0D0)
- XBACK = c_add(XBACK, c_mul(TWO_N_P_ONE * FACTOR, c_sub(AN, BN)))
-
-! FSB calculate the sum for the asymmetry factor
-
- GSCA = GSCA + ((TWO_N_P_ONE)/(RN* (RN + ONE)))* &
- (an%real_part*bn%real_part + an%imag_part*bn%imag_part)
-
- IF (n .GT. 1) THEN
-
- GSCA = GSCA + (RN - RN1) * &
- (AN1%real_part*AN%real_part + AN1%imag_part*AN%imag_part + &
- BN1%real_part*BN%real_part + BN1%imag_part*BN%imag_part)
-
- END IF
-! continue update for next interation
- psi0y = psi1y
- psi1y = psiy
- chi0y = chi1y
- chi1y = chiy
- xi1y = c_sub(psi1y, c_mul(chi1y, II))
- chi0x2 = chi1x2
- chi1x2 = chix2
- chi0y2 = chi1y2
- chi1y2 = chiy2
- d0x1 = d1x1
- d0x2 = d1x2
- d0y2 = d1y2
- END DO ! end of main loop
-
-!*** Have summed sufficient terms.
-! Now compute QQSCA,QQEXT,QBACK,and GSCA
- GGSCA = REAL( TWO * GSCA / qsca )
- QQSCA = REAL( TWO * qsca * RYY )
- QQEXT = REAL( TWO * qext * RYY )
-
- QBACK = 0.5 * real((xback%real_part**2 + xback%imag_part**2) * RYY)
-
- end subroutine BHCOAT
-
-! ------------------------------------------------------------------
- subroutine ghintBH_Odd (INIT, crefin,alfv,xlnsig,Qext_GH,Qscat_GH,g_gh, success )
-
-! *************** REVISED VERSION < NOTE
-! FSB *********** This is the newest (04_14_2012) version of GhintBH
-! this version does the Mie method and calculates the optimum set of
-! set of Gauss-Hermite abscissas and weights.
-! Dr. Francis S. Binkowski, The University of North Carolina
-! at Chapel Hill
-! FSB this code file now contains all of the necessary subroutines that
-! are called to perform an integral of the Bohren and Huffman
-! Mie codes ( as updated by Prof. Bruce C. Drain of Princeton)
-! calculates the extinction and scattering coefficients
-! normalized by wavelength and total particle volume
-! concentration for a log normal particle distribution
-! with the logarithm of the geometric standard deviation
-! given by xlnsig. The integral of the
-! asymmetry factor g is also calculated.
-! FSB Change 12/20/2011 This code now has a choice of IGH based
-! upon alfv and nr.
-! FBB Changes Simplified code. Eliminated Penndorf code
-! *** Does Gauss-Hermite quadrature of Qext / alfa & Qscat / alfa
-! and asymmetry factor over log normal distribution using
-! symmetric points.
-!
- implicit none
-
- logical, intent(INOUT) :: INIT ! initialize number of qudraure points
- complex, intent(in) :: crefin ! complex index of refraction
- real, intent(in) :: alfv ! Mie parameter for dgv
- real, intent(in) :: xlnsig ! log of geometric standard deviation
- real, intent(out) :: Qext_GH ! normalized extinction efficiency
- real, intent(out) :: Qscat_GH ! normalized scattering efficiency
- real, intent(out) :: g_GH ! asymmetry factor
- logical, intent(out) :: success ! flag for successful calculation
-
- real :: nr ! real part of refractive index
- real :: aa1 ! see below for definition
- real :: alfaip, alfaim ! Mie parameters at abscissas
-
-! *** these are Qext/alfa and Qscat/alfv at the abscissas
- real :: qalfip_e, qalfim_e ! extinction
- real :: qalfip_s, qalfim_s ! scattering
- real :: gsalfp, gsalfm ! scattering times asymmetry factor
-
-! FSB define parameters
- real, parameter :: pi = 3.14159265
- real, parameter :: sqrtpi = 1.772454
- real, parameter :: sqrtpi1 = 1.0 / sqrtpi
- real, parameter :: sqrt2 = 1.414214
- real, parameter :: three_pi_two = 3.0 * pi / 2.0
- real, parameter :: const = three_pi_two * sqrtpi1
-
- integer :: i
- real :: sum_e,sum_s, xi,wxi,xf
- real :: sum_sg
-
- real, allocatable, save :: GHXI(:), GHWI(:) ! weight and abscissas
- integer, save :: IGH ! number of weights and abscissa
- integer, save :: NMAX ! optimumized number of weights and abscissa
-
-
-! start code
-! FSB now choose IGH. These choices are designed to improve
-! the computational efficiency without sacrificing accuracy.
-
- If( INIT )Then
-
- Select Case( Quadrature_Points )
- Case( 1,3,9 )
- IGH = Quadrature_Points
- Case Default
- IGH = 3
- End Select
-
- NMAX = Max( Int( IGH / 2 ), 0)
-
- If( Allocated( GHXI ) .Or. Allocated( GHWI ) )Then
- Success = .False.
- Return
- End If
-
- Allocate( GHXI( NMAX + 1 ), GHWI( NMAX + 1 ) )
-
- Select Case ( IGH )
- Case ( 1 )
- GHXI(1) = ghxi_1(1)
- GHWI(1) = ghwi_1(1)
- Case ( 3 )
- do i = 1, NMAX + 1
- GHXI(i) = ghxi_3(i)
- GHWI(i) = ghwi_3(i)
- end do
- Case ( 9 )
- do i = 1, NMAX + 1
- GHXI(i) = ghxi_9(i)
- GHWI(i) = ghwi_9(i)
- end do
- end select
-
- If( AERO_UTIL_LOG .GT. 0 )Then
- write(AERO_UTIL_LOG,*)'BHMIE: IGH,(NMAX + 1) = ',IGH,(NMAX + 1)
- do i = 1, NMAX + 1
- write(AERO_UTIL_LOG,*)'BHMIE: i, GHXI(i), GHWI(i) = ',i, GHXI(i), GHWI(i)
- end do
- End If
-
- INIT = .False.
- Else
- If( .Not. Allocated( GHXI ) .Or. .Not. Allocated( GHWI ) )Then
- Success = .False.
- Return
- End If
- End If ! set up number of abscissas and weights
-
- nr = real(crefin)
-
-! FSB now start the integration code
- aa1 = sqrt2 * xlnsig ! This 1.0 / Sqrt( A ) in derivation of the integral
- ! where A = 1.0 / ( 2.0 * xlnsg**2 )
-
-! Then alpha = alfv * exp[ u / sqrt(A) ]
-! For Gauss-Hermite Quadrature u = xi
-! Therefore, xf = exp( xi / sqrt(A) ),
-! or xf = exp( xi * aa1 )
-
-!start integration at zero point
- xi = 0.0
- wxi = GHWI(NMAX+1)
- xf = 1.0
- alfaip = alfv
-! fetch the effficiencies at zero point
-
- call getqext_BH(alfaip,crefin,qalfip_e,qalfip_s, gsalfp, success)
-
- sum_e = wxi * qalfip_e
- sum_s = wxi * qalfip_s
- sum_sg = wxi * gsalfp
-
-! FSB do NMAX calls to the MIE codes
- do i = 1, NMAX
- xi = GHXI(i)
- wxi = GHWI(i)
- xf = exp( xi * aa1 )
- alfaip = alfv * xf
- alfaim = alfv / xf ! division cheaper than another exp()
-! *** call subroutine to fetch the effficiencies
-
- call getqext_BH(alfaip,crefin,qalfip_e,qalfip_s, gsalfp, success)
- call getqext_BH(alfaim,crefin,qalfim_e,qalfim_s, gsalfm, success)
-
- sum_e = sum_e + wxi * ( qalfip_e + qalfim_e )
- sum_s = sum_s + wxi * ( qalfip_s + qalfim_s )
- sum_sg = sum_sg + wxi * ( gsalfp + gsalfm )
-
- end do
-
- g_GH = sum_sg / sum_s ! this is
- Qext_GH = const * sum_e !
- Qscat_GH = const * sum_s
-
- end subroutine ghintBH_Odd
-
-! ------------------------------------------------------------------
- subroutine ghintBH_CS_Odd (INIT, RCORE, RSHELL , XX, YY, xlnsig, &
- Qext_GH,Qscat_GH, g_gh, success)
-
-! FSB code for coated-sphere (core-shell) version
-
-! *************** REVISED VERSION < NOTE
-! FSB *********** This is the newest (04_14_2012) version of ghintBH_CS
-! for the coated-sphere (core-shell) method using BHCOAT
-! this version does the Mie method and calculates the optimum set of
-! set of Gauss-Hermite abscissas and weights.
-! Dr. Francis S. Binkowski, The University of North Carolina
-! at Chapel Hill
-
-! FSB this code file now contains all of the necessary subroutines that
-! are called to perform an integral of the Bohren and Huffman
-! Mie codes ( as updated by Prof. Bruce C. Drain of Princeton)
-! calculates the extinction and scattering coefficients
-! normalized by wavelength and total particle volume
-! concentration for a log normal particle distribution
-! with the logarithm of the geometric standard deviation
-! given by xlnsig. The integral of the
-! asymmetry factor g is also calculated.
-! FSB Change 12/20/2011 This code now has a choice of IGH based
-! upon alfv and nr.
-! FBB Changes Simplified code. Eliminated Penndorf code
-! *** Does Gauss-Hermite quadrature of Qext / alfa & Qscat / alfa
-! and asymmetry factor over log normal distribution using
-! symmetric points.
-!
- implicit none
-
- logical, intent(inout) :: INIT ! initialize number of qudraure points
- complex, intent(in) :: RCORE ! refractive index of core
- complex, intent(in) :: RSHELL ! refractive index of shell
- real, intent(in) :: XX ! Mie parameter for core
- real, intent(in) :: YY ! Mie parameter for shell
- real, intent(in) :: xlnsig ! log of geometric standard deviation
- real, intent(out) :: Qext_GH ! normalized extinction efficiency
- real, intent(out) :: Qscat_GH ! normalized scattering efficiency
- real, intent(out) :: g_GH ! asymmetry factor
- logical, intent(out) :: success ! flag for successful calculation
-
- real :: nr ! real part of refractive index
- real :: aa1 ! see below for definition
- real :: XXP, XXM ! Mie parameters at abscissas - CORE
- real :: YYP, YYM ! Mie parameters at abscissas - SHELL
-
-! FSB define parameters
- real, parameter :: pi = 3.14159265
- real, parameter :: sqrtpi = 1.772454
- real, parameter :: sqrtpi1 = 1.0 / sqrtpi
- real, parameter :: sqrt2 = 1.414214
- real, parameter :: three_pi_two = 3.0 * pi / 2.0
- real, parameter :: const = three_pi_two * sqrtpi1
-
-! *** these are Qext/alfa and Qscat/alfv at the abscissas
- real :: qalfip_e, qalfim_e ! extinction
- real :: qalfip_s, qalfim_s ! scattering
- real :: gsalfp, gsalfm ! scattering times asymmetry factor
- integer :: i
- real :: sum_e,sum_s, xi,wxi,xf, temp
- real :: sum_sg
-
- real, allocatable, save :: GHXI(:), GHWI(:) ! weight and abscissas
- integer, save :: IGH ! number of weights and abscissa
- integer, save :: NMAX ! optimized number of weights and abscissa
-
-! start code
-! FSB now choose IGH. These choices are designed to improve
-! the computational efficiency without sacrificing accuracy.
-
- If( INIT )Then
-
- Select Case( Quadrature_Points )
- Case( 1,3,9 )
- IGH = Quadrature_Points
- Case Default
- IGH = 3
- End Select
-
- If( Allocated( GHXI ) .Or. Allocated( GHWI ) )Then
- Success = .False.
- Return
- End If
-
- NMAX = Max( Int( IGH / 2 ), 0)
-
- Allocate( GHXI( NMAX + 1 ), GHWI( NMAX + 1 ) )
-
- Select Case ( IGH )
- Case ( 1 )
- GHXI(1) = ghxi_1(1)
- GHWI(1) = ghwi_1(1)
- Case ( 3 )
- do i = 1, NMAX + 1
- GHXI(i) = ghxi_3(i)
- GHWI(i) = ghwi_3(i)
- end do
- Case ( 9 )
- do i = 1, NMAX + 1
- GHXI(i) = ghxi_9(i)
- GHWI(i) = ghwi_9(i)
- end do
- end select
-
- If( AERO_UTIL_LOG .GT. 0 )Then
- write(AERO_UTIL_LOG,*)'BHCoat: IGH,(NMAX + 1) = ',IGH,(NMAX + 1)
- do i = 1, NMAX + 1
- write(AERO_UTIL_LOG,*)'BHCoat: i, GHXI(i), GHWI(i) = ',i, GHXI(i), GHWI(i)
- end do
- End If
-
- INIT = .False.
-
- Else
- If( .Not. Allocated( GHXI ) .Or. .Not. Allocated( GHWI ) )Then
- Success = .False.
- Return
- End If
- End If ! set up number of abscissas and weights
-
- nr = real(RSHELL)
-
-! FSB now start the integration code
- aa1 = sqrt2 * xlnsig ! This 1.0 / Sqrt( A ) in derivation of the integral
- ! where A = 1.0 / ( 2.0 * xlnsg**2 )
-
-! Then alpha = alfv * exp[ u / sqrt(A) ]
-! For Gauss-Hermite Quadrature u = xi
-! Therefore, xf = exp( xi / sqrt(A) ),
-! or xf = exp( xi * aa1 )
-
-!start integration at zero point
-
- xi = 0.0
- wxi = GHWI(NMAX+1)
- xf = 1.0
- XXP = XX
- YYP = YY
-
-! fetch the effficiencies at zero point
-
- call getqsgBHCS(XXP,YYP,RCORE,RSHELL,qalfip_e,qalfip_s,gsalfp, success)
-
- sum_e = wxi * qalfip_e
- sum_s = wxi * qalfip_s
- sum_sg = wxi * gsalfp
-
-! FSB do NMAX calls to the MIE codes
- do i = 1, NMAX
- xi = GHXI(i)
- wxi = GHWI(i)
- xf = exp( xi * aa1 )
- temp = 1.0 / xf
- XXP = XX * xf
- XXM = XX * temp ! division cheaper than another exp()
- YYP = YY * xf
- YYM = YY * temp ! division cheaper than another exp()
-! *** call subroutine to fetch the effficiencies
-
- call getqsgBHCS(XXP,YYP,RCORE,RSHELL,qalfip_e,qalfip_s,gsalfp, success)
- call getqsgBHCS(XXM,YYM,RCORE,RSHELL,qalfim_e,qalfim_s,gsalfm, success)
-
- sum_e = sum_e + wxi * ( qalfip_e + qalfim_e )
- sum_s = sum_s + wxi * ( qalfip_s + qalfim_s )
- sum_sg = sum_sg + wxi * ( gsalfp + gsalfm )
- end do
-
- g_GH = sum_sg / sum_s ! this is
- Qext_GH = const * sum_e !
- Qscat_GH = const * sum_s
-
- end subroutine ghintBH_CS_Odd
-
-! ------------------------------------------------------------------
- SUBROUTINE BHMIE_FLEXI (X, NMX, NSTOP, REFREL, QQEXT, QQSCA, QBACK, GSCA, SUCCESS)
-
-! FSB Changed the call vector to return only QEXT, QSCAT QBACK GSCA
-! and ignore NANG, S1 and S2 and all calculations for them
-
- implicit none
-
-! Arguments:
- real, intent(in) :: X ! X = pi*particle_diameter / Wavelength
- integer, intent(in) :: NMX ! maximum number of terms in Mie series
- integer, intent(in) :: NSTOP ! minumum number of terms in Mie series
- complex, intent(in) :: REFREL ! refractive index
-
-! REFREL = (complex refr. index of sphere)/(real index of medium)
-! in the current use the index of refraction of the the medium
-! i taken at 1.0 real.
-!
-! Output
-
- real, intent(out) :: QQEXT, QQSCA, QBACK, GSCA
- logical, intent(out) :: SUCCESS
-
-! QQEXT Efficiency factor for extinction
-! QQSCA Efficiency factor for scattering
-! QQBACK Efficiency factor for back scatter
-! GSCA asymmetry factor
-! SUCCESS flag for successful calculation
-! REFERENCE:
-! Bohren, Craig F. and Donald R. Huffman, Absorption and
-! Scattering of Light by Small Particles, Wiley-Interscience
-! copyright 1983. Paperback Published 1998.
-! FSB
-! This code was originally listed in Appendix A. pp 477-482.
-! As noted below, the original code was subsequently
-! modified by Prof. Bruce T. Drain of Princetion University.
-! The code was further modified for a specific application
-! in a large three-dimensional code requiring as much
-! computational efficiency as possible.
-! Prof. Francis S. Binkowski of The University of North
-! Carolina at Chapel Hill.
-
-! Declare parameters:
-! Note: important that MXNANG be consistent with dimension of S1 and S2
-! in calling routine!
-
- integer, parameter :: MXNANG=10, NMXX=150000 ! FSB new limits
- integer, parameter :: NANG = 2
- real*8, parameter :: PII = 3.1415916536D0
- real*8, parameter :: ONE = 1.0D0, TWO = 2.0D0
- complex*16, parameter :: COMPLEX_DZERO = (0.0D0,0.0D0)
- complex, parameter :: COMPLEX_ZERO = (0.0,0.0)
-
-! Local variables:
- integer :: N, NN
- real*8 :: QSCA, QEXT, DX1, DXX1
- real*8 :: CHI,CHI0,CHI1,DX,EN,P,PSI,PSI0,PSI1,XSTOP,YMOD
- real*8 :: TWO_N_M_ONE, TWO_N_P_ONE, EN1, FACTOR
- complex*16 :: AN,AN1,BN,BN1,DREFRL,XI,XI1,Y, Y1, DREFRL1
- complex*16 :: D(NMX)
- complex*16 :: FAC1, FAC2
- complex*16 :: XBACK
-
-!***********************************************************************
-! Subroutine BHMIE is the Bohren-Huffman Mie scattering subroutine
-! to calculate scattering and absorption by a homogenous isotropic
-! sphere.
-! Given:
-! X = 2*pi*a/lambda
-! REFREL = (complex refr. index of sphere)/(real index of medium)
-! real refractive index of medium taken as 1.0
-! Returns:
-! QEXT = efficiency factor for extinction
-! QSCA = efficiency factor for scattering
-! QBACK = efficiency factor for backscatter
-! see Bohren & Huffman 1983 p. 122
-! GSCA = asymmetry for scattering
-!
-! Original program taken from Bohren and Huffman (1983), Appendix A
-! Modified by Prof. Bruce T.Draine, Princeton Univ. Obs., 90/10/26
-! in order to compute
-! 91/05/07 (BTD): Modified to allow NANG=1
-! 91/08/15 (BTD): Corrected error (failure to initialize P)
-! 91/08/15 (BTD): Modified to enhance vectorizability.
-! 91/08/15 (BTD): Modified to make NANG=2 if called with NANG=1
-! 91/08/15 (BTD): Changed definition of QBACK.
-! 92/01/08 (BTD): Converted to full double precision and double complex
-! eliminated 2 unneed lines of code
-! eliminated redundant variables (e.g. APSI,APSI0)
-! renamed RN -> EN = double precision N
-! Note that DOUBLE COMPLEX and DCMPLX are not part
-! of f77 standard, so this version may not be fully
-! portable. In event that portable version is
-! needed, use src/bhmie_f77.f
-! 93/06/01 (BTD): Changed AMAX1 to generic function MAX
-! FSB April 09,2012 This code was modified by:
-! Prof. Francis S. Binkowski University of North Carolina at
-! Chapel Hill, Institue for the Environment.
-!
-! The modifications were made to enhance computation speed
-! for use in a three-dimensional code. This was done by
-! removing code that calculated angular scattering. The method
-! of calculating QEXT, QBACK was also changed.
-
-!***********************************************************************
-!*** Safety checks
-
- SUCCESS = .TRUE.
-! NANG = 2 ! FSB only this value
-! IF(NANG.GT.MXNANG)STOP'***Error: NANG > MXNANG in bhmie'
-! IF (NANG .LT. 2) NANG = 2
-
- DX = REAL( X, 8 )
-! FSB Define reciprocals so that divisions can be replaced by multiplications.
- DX1 = ONE / DX
- DXX1 = DX1 * DX1
- DREFRL = DCMPLX( REAL( REFREL ), IMAG( REFREL ) )
- DREFRL1 = ONE / DREFRL
- Y = DX * DREFRL
- Y1 = ONE / Y
-! YMOD = ABS(Y)
-
-!*** Series expansion terminated after NSTOP terms
-! Logarithmic derivatives calculated from NMX on down
-! XSTOP = X + 4.0 * X**0.3333 + 2.0
-! NMX = MAX(XSTOP,YMOD) + 15
-
-! BTD experiment 91/1/15: add one more term to series and compare results
-! NMX=AMAX1(XSTOP,YMOD)+16
-! test: compute 7001 wavelengths between .0001 and 1000 micron
-! for a=1.0micron SiC grain. When NMX increased by 1, only a single
-! computed number changed (out of 4*7001) and it only changed by 1/8387
-! conclusion: we are indeed retaining enough terms in series!
-
- FACTOR = 1.0D0
-
-! IF (NMX .GT. NMXX) THEN
-! WRITE(6,*)'Error: NMX > NMXX=',NMXX,' for |m|x=',YMOD
-! SUCCESS = .FALSE.
-! RETURN
-! END IF
-
-! FSB all code relating to scattering angles is removed out for
-! reasons of efficiency when running in a three-dimensional
-! code. We only need QQSCA, QQEXT, GSCA AND QBACK
-
-!*** Logarithmic derivative D(J) calculated by downward recurrence
-! beginning with initial value (0.,0.)
-
- D(NMX) = COMPLEX_DZERO
- NN = NMX - 1
- DO N = 1,NN
- EN = REAL( NMX - N + 1, 8 )
-! FSB In the following division by Y has been replaced by
-! multiplication by Y1, the reciprocal of Y.
- D(NMX-N) = ( EN * Y1 ) - (ONE / ( D(NMX-N+1) + EN * Y1))
- END DO
-
-!*** Riccati-Bessel functions with real argument X
-! calculated by upward recurrence
-
- PSI0 = COS(DX)
- PSI1 = SIN(DX)
- CHI0 = -SIN(DX)
- CHI1 = PSI0
- XI1 = DCMPLX(PSI1,-CHI1)
- QSCA = 0.0D0
- GSCA = 0.0D0
- QEXT = 0.0D0
- P = -ONE
- XBACK = COMPLEX_DZERO
-
-! FSB Start main loop
- DO N = 1,NSTOP
- EN = REAL( N, 8 )
- EN1 = ONE / EN
- TWO_N_M_ONE = TWO * EN - ONE
-! for given N, PSI = psi_n CHI = chi_n
-! PSI1 = psi_{n-1} CHI1 = chi_{n-1}
-! PSI0 = psi_{n-2} CHI0 = chi_{n-2}
-! Calculate psi_n and chi_n
- PSI = TWO_N_M_ONE * PSI1 * DX1 - PSI0
- CHI = TWO_N_M_ONE * CHI1 * DX1 - CHI0
- XI = DCMPLX(PSI,-CHI)
-
-!*** Compute AN and BN:
-! FSB Rearrange to get common terms
- FAC1 = D(N) * DREFRL1 + EN * DX1
- AN = (FAC1) * PSI - PSI1
- AN = AN / ( (FAC1 )* XI - XI1 )
- FAC2 = ( DREFRL * D(N) + EN * DX1)
- BN = ( FAC2) * PSI -PSI1
- BN = BN / ((FAC2) * XI - XI1 )
-
-! FSB calculate sum for QEXT as done by Wiscombe
-! get common factor
- TWO_N_P_ONE = (TWO * EN + ONE)
- QEXT = QEXT + (TWO_N_P_ONE) * (REAL(AN) + REAL(BN) )
- QSCA = QSCA + (TWO_N_P_ONE) * ( ABS(AN)**2 + ABS(BN)**2 )
-
-! FSB calculate XBACK from B & H Page 122
- FACTOR = -1.0d0 * FACTOR ! calculate (-1.0 ** N)
- XBACK = XBACK + (TWO_N_P_ONE) * factor * (AN - BN)
-
-! FSB calculate asymmetry factor
-
- GSCA = GSCA + REAL((TWO_N_P_ONE)/(EN * (EN + ONE)) * &
- (REAL(AN)*REAL(BN)+IMAG(AN)*IMAG(BN)))
-
- IF (N .GT. 1)THEN
- GSCA = GSCA + REAL((EN - EN1) * &
- (REAL(AN1)*REAL(AN) + IMAG(AN1)*IMAG(AN) + &
- REAL(BN1)*REAL(BN) + IMAG(BN1)*IMAG(BN)))
- ENDIF
-
-!*** Store previous values of AN and BN for use in computation of g=
- AN1 = AN
- BN1 = BN
-
-! FSB set up for next iteration
- PSI0 = PSI1
- PSI1 = PSI
- CHI0 = CHI1
- CHI1 = CHI
- XI1 = DCMPLX(PSI1,-CHI1)
-
- END DO ! main loop on n
-
-!*** Have summed sufficient terms.
-
-! Now compute QQSCA,QQEXT,QBACK,and GSCA
- GSCA = REAL( TWO / QSCA ) * GSCA
-
-! FSB in the following, divisions by DX * DX has been replaced by
-! multiplication by DXX1 the reciprocal of 1.0 / (DX *DX)
- QQSCA = REAL( TWO * QSCA * DXX1 )
- QQEXT = REAL( TWO * QEXT * DXX1 )
- QBACK = REAL( REAL( 0.5D0 * XBACK * CONJG(XBACK), 8 ) * DXX1 ) ! B&H Page 122
-
- END subroutine BHMIE_FLEXI
-
-END MODULE rrtmg_aero_optical_util_module
-
-! ------------------------------------------------------------------
-! FSB REvised Mie calculations 02/09/2011
-
-MODULE module_twoway_ra_rrtmg_sw
-
-contains
-
-!------------------------------------------------------------------
- Subroutine get_aerosol_Optics_RRTMG_SW ( ns, nmode,delta_z, INMASS_ws, &
- INMASS_in, INMASS_ec, INMASS_ss, &
- INMASS_h2o, INDGN, INSIG, &
- tauaer, waer, gaer )
-
-!FSB This version switches between BHCOAT to BHMIE depending upon whether
-! EC is present or not. 04/15/2012.
-
-!FSB this version does a core-shell calculation with BHCOAT 04/11/2012
-! This version is set up to be used with RRTMG_SW <<<<<<<<
-! wavelenght is calculated internally
-! FSB This routine calculates the aerosol information ( tauaer, waer,
-! gaer, needed to calculate the solar radiation) The calling
-! program specifies the location ( row, column, layer,
-! layer thicknes, and wave length for the calculation.
-! FSB 02/09/2011 Modifications made to subroutine ghintBH.
-! FSB 04/14/2012 REmoved MODULUS, made changes to ghintBH.
-! Put in option for core-shell (coated-sphere). 2
-
-! FSB Input variables:
-
- use rrtmg_aero_optical_util_module
-
- implicit none
-
- integer,intent(in) :: ns ! index for wavelength should be
- ! between 1 and 14. <<< RRTMG_SW
- integer,intent(in) :: nmode ! should be 3 for WRF/CMAQ calculation
- real,intent(in) :: delta_z ! layer thickness [m]
-! FSB mode types for WRF/CMAQ
-! nmode = 1 Aitken
-! nmode = 2 accumulation
-! nmode = 3 coarse
-! FSB modal mass concentration by species [ ug / m**3] NOTE: MKS
- real, intent(in) :: INMASS_ws(nmode) ! water soluble
- real, intent(in) :: INMASS_in(nmode) ! insolugle
- real, intent(in) :: INMASS_ec(nmode) ! elemental carbon or soot like
- real, intent(in) :: INMASS_ss(nmode) ! sea salt
- real, intent(in) :: INMASS_h2o(nmode) ! water
-! FSB particle size-distribution information
- real, intent(in) :: INDGN( nmode) ! geometric mean diameter [ m ] NOTE: MKS
- real, intent(in) :: INSIG( nmode) ! geometric standard deviation
-
-!FSB output aerosol radiative properties [dimensionless]
- real, intent(out) :: tauaer ! aerosol extinction optical depth
- real, intent(out) :: waer ! aerosol single scattering albedo
- real, intent(out) :: gaer ! aerosol assymetry parameter
-
-! FSB Internal variables
-
- real :: NR(nmode), NI(nmode) ! refractive indices
- complex :: refcor(nmode), refshell(nmode) ! complex refracive indices
- complex :: crefin(nmode) ! complex refractive index
-
-! FSB special values for EC CORE-shell calculation
- real :: DGNSHELL(nmode) ! modal geometric mean diameter [m]
- real :: DGNCORE (nmode) ! modal geometric mean diameter [m]
-
-! FSB Modal volumes [ m**3 / m**3 ]
- real :: MVOL_ws(nmode) ! water soluble
- real :: MVOL_in(nmode) ! insolugle
- real :: MVOL_ec(nmode) ! soot like
- real :: MVOL_ss(nmode) !sea salt
- real :: MVOL_h2o(nmode) ! water
-! real :: VOL(nmode) ! total modal volume [m** 3 / m**3]
-! FSB special values for EC CORE-shell calculation
- real :: VOLCOR(nmode) ! volume of EC core [m** 3 / m**3]
- real :: VOLSHELL(nmode) ! volume of shell [m** 3 / m**3]
-
- integer :: m ! loop index
- real :: bext ! extinction coefficient [1 / m]
- real :: bscat ! scattering coefficient [1 / m]
- real :: gfac ! asymmetry factor
-
- real :: bextsum, bscatsum, bsgsum
-
-! FSB History variables by wavelength and mode
-! real :: bext_wm(ns,nmode)
-! real :: bscat_wm(ns,nmode)
-! real :: gfac_wm(ns,nmode)
-
- real, parameter :: one3rd = 1.0 / 3.0
- real :: dfac ! ratio of (volcor/vol) ** one3rd
- ! used for calculating the diameter
- ! of the EC core
-
- logical :: succesS
-
-!...component densities [ g/ cm**3 ] <<<<< cgs
-
- real, parameter :: rhows = 1.8 ! bulk density of water soluble aerosol
-
- real, parameter :: rhoin = 2.2 ! bulk density forinsoluble aerosol
-
-! real, parameter :: rhoec = 1.7 ! bulk density for soot aerosol
- real, parameter :: rhoec = 1.8 ! new value
-
- real, parameter :: rhoh2o = 1.0 ! bulk density of aerosol water
-
- real, parameter :: rhoss = 2.2 ! bulk density of seasalt
-
-! FSB scale factor for volume calculation
-! 1.0d-12 * [ cm**3 / g] -> [ m** 3 / ug ]
- real, parameter :: scalefactor = 1.0e-12
-
-! FSB scale factor for [1/g] to [1/ug]
- real, parameter :: cug2g = 1.0e-06
-
-! FSB reciprocal component densities[ m ** 3 / ug ]
-
- real, parameter :: rhows1 = scalefactor / rhows ! water soluble aerosol
-
- real, parameter :: rhoin1 = scalefactor / rhoin ! insoluble aerosol
-
- real, parameter :: rhoec1 = scalefactor / rhoec ! soot aerosol
-
- real, parameter :: rhoh2o1 = scalefactor / rhoh2o ! aerosol water
-
- real, parameter :: rhoss1 = scalefactor / rhoss ! seasalt
-
- integer,parameter :: nspint_sw = 14 ! number of spectral intervals for RRTMG_SW
-
-! FSB Band numbers and wavelengths for RRTMG_SW
- integer, parameter :: Band(nspint_sw) = (/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14 /)
-
- real, parameter :: LAMDA_SW(nspint_sw) = (/ 3.4615, 2.7885, 2.325, 2.046, 1.784, &
- 1.4625, 1.2705, 1.0101, 0.7016, 0.53325, &
- 0.38815, 0.299, 0.2316, 8.24 /) ! wavelength [ um ]
-
-! *** refractive indices
-
-! *** Except as otherwise noted reference values of refractive
-! indices for aerosol particles are from the OPAC Data base.
-! Hess, Koepke, and Schult, Optical properties of
-! aerosols and clouds: The software package OPAC, Bulletan of
-! the American Meteorological Society, Vol 79, No 5,
-! pp 831 - 844, May 1998.
-! OPAC is a downloadable data set of optical properties of
-! 10 aerosol components, 6 water clouds and 3 cirrus clouds
-! at UV, visible and IR wavelengths
-! www.lrz-muenchen.de/~uh234an/www/radaer/opac.htm
-
-
-! FSB water soluble
- real, parameter :: xnreal_ws(nspint_sw) = (/ 1.443, 1.420, 1.420, 1.420, 1.463, 1.510, 1.510, &
- 1.520, 1.530, 1.530, 1.530, 1.530, 1.530, 1.710 /)
- real, parameter :: xnimag_ws(nspint_sw) = (/ 5.718E-3, 1.777E-2, 1.060E-2, 8.368E-3, 1.621E-2, &
- 2.198E-2, 1.929E-2, 1.564E-2, 7.000E-3, 5.666E-3, &
- 5.000E-3, 8.440E-3, 3.000E-2, 1.100E-1 /)
-
-! FSB sea salt
- real, parameter :: xnreal_ss(nspint_sw) = (/ 1.480, 1.534, 1.437, 1.448, 1.450, 1.462, 1.469, &
- 1.470, 1.490, 1.500, 1.502, 1.510, 1.510, 1.510 /)
-
- real, parameter :: xnimag_ss(nspint_sw) = (/ 1.758E-3, 7.462E-3, 2.950E-3, 1.276E-3, 7.944E-4, &
- 5.382E-4, 3.754E-4, 1.498E-4, 2.050E-7, 1.184E-8, &
- 9.938E-8, 2.060E-6, 5.000E-6, 1.000E-2 /)
-
-! FSB insoluble
- real, parameter :: xnreal_in(nspint_sw) = (/ 1.272, 1.168, 1.208, 1.253, 1.329, 1.418, 1.456, &
- 1.518, 1.530, 1.530, 1.530, 1.530, 1.530, 1.470 /)
- real, parameter :: xnimag_in(nspint_sw) = (/ 1.165E-2, 1.073E-2, 8.650E-3, 8.092E-3, 8.000E-3, &
- 8.000E-3, 8.000E-3, 8.000E-3, 8.000E-3, 8.000E-3, &
- 8.000E-3, 8.440E-3, 3.000E-2,9.000E-2 /)
-
-! FSB 02/11/2012 These values are replaced.
-! data xnreal_ec /1.877, 1.832, 1.813, 1.802, 1.791, 1.769, 1.761, &
-! 1.760, 1.750, 1.740, 1.750, 1.738, 1.620, 2.120/
-! data xnimag_ec/ 5.563E-1, 5.273E-1, 5.030E-1, 4.918E-1, 4.814E-1, &
-! 4.585E-1, 4.508E-1, 4.404E-1, 4.300E-1, 4.400E-1, &
-! 4.600E-1, 4.696E-1, 4.500E-1, 5.700E-1/
-
-! New Refractive indices for EC at RRTMG Wavelengths
-! Source lamda xnreal_ec xnimag_ec
-! C&C Values
-! 3.4615 2.089 1.070
-! 2.7885 2.014 0.939
-! 2.325 1.962 0.843
-! 2.046 1.950 0.784
-! Bond values
-! 1.784 1.940 0.760
-! 1.4625 1.930 0.749
-! 1.2705 1.905 0.737
-! 1.0101 1.870 0.726
-! B&B Values
-! 0.7016 1.85 0.71
-! 0.53325 1.85 0.71
-! 0.38815 1.85 0.71
-! 0.299 1.85 0.71
-! 0.2316 1.85 0.71
-! C & C values
-! 8.24 2.589 1.771
-!References:
-! Bond Personal Communication from Tami Bond
-! B&B Bond, T.C. & R.W. Bergstrom (2006) Light absorption by
-! Carbonaceous Particles: An investigative review,
-! Aerosol Science and Technology. Vol. 40. pp 27-67
-!
-! C&C Chang,H and T.T. Charalmpopoulos (1990) Determination of the
-! wavelength dependence of refractive indices of flame soot,
-! Proceeding of the Royal Society of London A, Vol. 430, pp 577-591.
-! FSB new values
-
-! FSB elemental carbon - soot like
-
- real, parameter :: xnreal_ec(nspint_sw) = (/ 2.089, 2.014, 1.962, 1.950, 1.940, 1.930, 1.905, &
- 1.870, 1.85, 1.85, 1.85, 1.85, 1.85, 2.589 /)
- real, parameter :: xnimag_ec(nspint_sw) = (/ 1.070, 0.939, 0.843, 0.784, 0.760, 0.749, 0.737, &
- 0.726, 0.71, 0.71, 0.71, 0.71, 0.71, 1.771 /)
-
-! FSB water
- real, save :: xnreal_h2o(nspint_sw) = (/ 1.408, 1.324, 1.277, 1.302, 1.312, 1.321, 1.323, &
- 1.327, 1.331, 1.334, 1.340, 1.349, 1.362, 1.260 /)
- real, save :: xnimag_h2o(nspint_sw) = (/ 1.420E-2, 1.577E-1, 1.516E-3, 1.159E-3, 2.360E-4, &
- 1.713E-4, 2.425E-5, 3.125E-6, 3.405E-8, 1.639E-9, &
- 2.955E-9, 1.635E-8, 3.350E-8, 6.220E-2 /)
-
-! FSB Begin code ======================================================
-
- bextsum = 0.0
- bscatsum = 0.0
- bsgsum = 0.0
- do m = 1, nmode
-! FSB calculate volumes [ m**3 / m**3 ]
-! FSB the reciprocal densities have been scaled to [ m**3 / ug ]
-
- MVOL_ws(m) = rhows1 * INMASS_ws(m)
- MVOL_in(m) = rhoin1 * INMASS_in(m)
- MVOL_ec(m) = rhoec1 * INMASS_ec(m)
- MVOL_ss(m) = rhoss1 * INMASS_ss(m)
- MVOL_h2o(m) = rhoh2o1 * INMASS_h2o(m)
-
- VOLSHELL(m) = MVOL_ws(m) + MVOL_in(m) + MVOL_ss(m) + MVOL_h2o(m)
- VOLCOR(m) = MVOL_ec(m)
-! VOL(m) = VOLSHELL(m) + VOLCOR(m) ! VOL is total volume
-
- if ( VOLCOR(m) .gt. 0.0 ) then
-! FSB EC is present
-! calculate the ratio of core to shell volume
-! take cube root for scaling the diameter of
-! the core to that of the shell.
-
-! dfac = ( VOLCOR(m) / VOL(m) ) ** one3rd
- dfac = ( VOLCOR(m) / ( VOLSHELL(m) + VOLCOR(m) ) ) ** one3rd
-! dfac = ( VOLCOR(m) / ( VOLSHELL(m) + VOLCOR(m) ) )
-! FSB Set shell and core diameters
- DGNSHELL(m) = INDGN(m)
- DGNCORE(M) = dfac * INDGN(m)
-! FSB note that VOLSHELL(m) is the total volume when EC is not present
- end if
-
-! internal mixture of non-EC species.
-
-! modal real refractive index No EC
- nr(m) = (MVOL_ws(m) * xnreal_ws(ns) + &
- MVOL_in(m) * xnreal_in(ns) + &
- MVOL_ss(m) * xnreal_ss(ns) + &
-! MVOL_h2o(m) * xnreal_h2o(ns)) / VOL(m)
- MVOL_h2o(m) * xnreal_h2o(ns)) / VOLSHELL(m)
-
-! modal imaginary refractive index no EC
- ni(m) = (MVOL_ws(m) * xnimag_ws(ns) + &
- MVOL_in(m) * xnimag_in(ns) + &
- MVOL_ss(m) * xnimag_ss(ns) + &
-! MVOL_h2o(m) * xnimag_h2o(ns)) / VOL(m)
- MVOL_h2o(m) * xnimag_h2o(ns)) / VOLSHELL(m)
-
- if ( VOLCOR(m) .gt. 0.0) then
-
-! FSB calculate the complex refractive indices for the CORE and
-! the SHELL for case when and EC core is assumed to exist.
-
- refcor(m) = cmplx( xnreal_ec(ns), xnimag_ec(ns) )
- refshell(m) = cmplx(nr(m), ni(m) )
-! FSB do BHCOAT case
- CALL aero_optical_CS( LAMDA_SW(ns), refcor(m), refshell(m), &
- VOLCOR(m),VOLSHELL(m), DGNCORE(m), &
- DGNSHELL(m), INSIG(m), &
- bext, bscat, gfac, succesS )
-! else if ( VOL(m) .gt. 0.0) then
- else if ( VOLSHELL(m) .gt. 0.0) then
-! FSB do BHMIE case for the case when EC is not present.
- crefin(m) = cmplx(nr(m), ni(m) )
-! CALL aero_optical2( LAMDA_SW(ns), crefin(m), VOL(m), &
- CALL aero_optical2( LAMDA_SW(ns), crefin(m), VOLSHELL(m), &
- INDGN(m), INSIG(m), &
- bext, bscat, gfac, success )
- else
- bext = 0.0
- bscat = 0.0
- gfac = 0.0
- end if
-
-! FSB sum for total values
- bextsum = bextsum + bext
- bscatsum = bscatsum +bscat
- bsgsum = bsgsum + bscat * gfac
-! FSB get history
-! bext_wm(ns,m) = bext
-! bscat_wm(ns,m) = bscat
-! gfac_wm(ns,m) = gfac
- end do ! loop over modes
-
-! FSB construct output variables
- tauaer = bextsum * delta_z
- waer = bscatsum / bextsum
- gaer = bsgsum / bscatsum
-
- end subroutine get_aerosol_Optics_RRTMG_SW
-
-END MODULE module_twoway_ra_rrtmg_sw