diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 00000000..50bb5867 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "COSP"] + path = COSP + url = https://github.com/linjiongzhou/COSPv2.0.git diff --git a/COSP b/COSP new file mode 160000 index 00000000..9d910acb --- /dev/null +++ b/COSP @@ -0,0 +1 @@ +Subproject commit 9d910acba3e3a3151de231184d4b109f65e28aee diff --git a/FV3GFS/FV3GFS_io.F90 b/FV3GFS/FV3GFS_io.F90 index 87348d0a..d40cf7e1 100644 --- a/FV3GFS/FV3GFS_io.F90 +++ b/FV3GFS/FV3GFS_io.F90 @@ -59,7 +59,7 @@ module FV3GFS_io_mod !--- needed for dq3dt output use ozne_def, only: oz_coeff !--- needed for cold-start capability to initialize q2m - use gfdl_cld_mp_mod, only: wqs1, qsmith_init + use gfdl_cld_mp_mod, only: wqs, qs_init use coarse_graining_mod, only: block_mode, block_upsample, block_min, block_max, block_sum, weighted_block_average use coarse_graining_mod, only: MODEL_LEVEL, PRESSURE_LEVEL use coarse_graining_mod, only: vertical_remapping_requirements, get_coarse_array_bounds @@ -141,7 +141,7 @@ module FV3GFS_io_mod real(kind=kind_phys) :: zhour ! integer :: tot_diag_idx = 0 - integer, parameter :: DIAG_SIZE = 250 + integer, parameter :: DIAG_SIZE = 500 real(kind=kind_phys), parameter :: missing_value = 9.99e20 type(gfdl_diag_type), dimension(DIAG_SIZE) :: Diag, Diag_coarse, Diag_diag_manager_controlled, Diag_diag_manager_controlled_coarse !-RAB @@ -1523,7 +1523,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain, enforce_ !--- slmsk Sfcprop(nb)%slmsk(ix) = 0. !--- tsfc (tsea in sfc file) - Sfcprop(nb)%tsfc(ix) = 300. ! should specify some latitudinal profile + Sfcprop(nb)%tsfc(ix) = Model%Ts0 ! should specify some latitudinal profile !--- weasd (sheleg in sfc file) Sfcprop(nb)%weasd(ix) = 0.0 !--- tg3 @@ -1712,7 +1712,7 @@ subroutine sfc_prop_override(Sfcprop, Grid, Atm_block, Model, fv_domain) !--- read the sfc_prop_override namelist read(Model%input_nml_file, nml=sfc_prop_override_nml, iostat=ios) - call qsmith_init + call qs_init call mpp_error(NOTE, "Calling sfc_prop_override") @@ -1753,7 +1753,7 @@ subroutine sfc_prop_override(Sfcprop, Grid, Atm_block, Model, fv_domain) !--- t2m ! slt. unstable Sfcprop(nb)%t2m(ix) = Sfcprop(nb)%t2m(ix) * 0.98 !--- q2m ! use RH = 98% and assume ps = 1000 mb - Sfcprop(nb)%q2m(ix) = wqs1 (Sfcprop(nb)%t2m(ix), 1.e5/rd/Sfcprop(nb)%t2m(ix)) + Sfcprop(nb)%q2m(ix) = wqs (Sfcprop(nb)%t2m(ix), 1.e5/rd/Sfcprop(nb)%t2m(ix), Sfcprop(nb)%q2m(ix)) !--- vtype Sfcprop(nb)%vtype(ix) = 0 !--- stype @@ -1790,7 +1790,7 @@ subroutine sfc_prop_override(Sfcprop, Grid, Atm_block, Model, fv_domain) !--- t2m Sfcprop(nb)%t2m(ix) = stc * 0.98 !slt unstable !--- q2m ! use RH = 98% - Sfcprop(nb)%q2m(ix) = wqs1 (Sfcprop(nb)%t2m(ix), 1.e5/rd/Sfcprop(nb)%t2m(ix)) + Sfcprop(nb)%q2m(ix) = wqs (Sfcprop(nb)%t2m(ix), 1.e5/rd/Sfcprop(nb)%t2m(ix), Sfcprop(nb)%q2m(ix)) !--- vtype Sfcprop(nb)%vtype(ix) = vegtype !--- stype @@ -2308,34 +2308,34 @@ subroutine register_coarse_sfc_prop_restart_fields(Model, var2, var3, nvar2, nva character(len=8) :: dim_names_2d(3), dim_names_3d(4) !--- register the axes for restarts - call register_axis(Sfc_restart, 'xaxis_1', 'X') - call register_field(Sfc_restart, 'xaxis_1', 'double', (/'xaxis_1'/)) - call register_variable_attribute(Sfc_restart, 'xaxis_1', 'cartesian_axis', 'X', str_len=1) - call get_global_io_domain_indices(Sfc_restart, 'xaxis_1', is, ie, indices=buffer) - call write_data(Sfc_restart, "xaxis_1", buffer) + call register_axis(Sfc_restart_coarse, 'xaxis_1', 'X') + call register_field(Sfc_restart_coarse, 'xaxis_1', 'double', (/'xaxis_1'/)) + call register_variable_attribute(Sfc_restart_coarse, 'xaxis_1', 'cartesian_axis', 'X', str_len=1) + call get_global_io_domain_indices(Sfc_restart_coarse, 'xaxis_1', is, ie, indices=buffer) + call write_data(Sfc_restart_coarse, "xaxis_1", buffer) deallocate(buffer) - call register_axis(Sfc_restart, 'yaxis_1', 'Y') - call register_field(Sfc_restart, 'yaxis_1', 'double', (/'yaxis_1'/)) - call register_variable_attribute(Sfc_restart, 'yaxis_1', 'cartesian_axis', 'Y', str_len=1) - call get_global_io_domain_indices(Sfc_restart, 'yaxis_1', is, ie, indices=buffer) - call write_data(Sfc_restart, "yaxis_1", buffer) + call register_axis(Sfc_restart_coarse, 'yaxis_1', 'Y') + call register_field(Sfc_restart_coarse, 'yaxis_1', 'double', (/'yaxis_1'/)) + call register_variable_attribute(Sfc_restart_coarse, 'yaxis_1', 'cartesian_axis', 'Y', str_len=1) + call get_global_io_domain_indices(Sfc_restart_coarse, 'yaxis_1', is, ie, indices=buffer) + call write_data(Sfc_restart_coarse, "yaxis_1", buffer) deallocate(buffer) - call register_axis(Sfc_restart, 'zaxis_1', dimension_length=Model%lsoil) - call register_field(Sfc_restart, 'zaxis_1', 'double', (/'zaxis_1'/)) - call register_variable_attribute(Sfc_restart, 'zaxis_1', 'cartesian_axis', 'Z', str_len=1) + call register_axis(Sfc_restart_coarse, 'zaxis_1', dimension_length=Model%lsoil) + call register_field(Sfc_restart_coarse, 'zaxis_1', 'double', (/'zaxis_1'/)) + call register_variable_attribute(Sfc_restart_coarse, 'zaxis_1', 'cartesian_axis', 'Z', str_len=1) allocate( buffer(Model%lsoil) ) do lsoil=1, Model%lsoil buffer(lsoil) = lsoil end do - call write_data(Sfc_restart, 'zaxis_1', buffer) + call write_data(Sfc_restart_coarse, 'zaxis_1', buffer) deallocate(buffer) - call register_axis(Sfc_restart, 'Time', unlimited) - call register_field(Sfc_restart, 'Time', 'double', (/'Time'/)) - call register_variable_attribute(Sfc_restart, 'Time', 'cartesian_axis', 'T', str_len=1) - call write_data(Sfc_restart, 'Time', 1) + call register_axis(Sfc_restart_coarse, 'Time', unlimited) + call register_field(Sfc_restart_coarse, 'Time', 'double', (/'Time'/)) + call register_variable_attribute(Sfc_restart_coarse, 'Time', 'cartesian_axis', 'T', str_len=1) + call write_data(Sfc_restart_coarse, 'Time', 1) !--- Assign dimensions to array for use in register_restart_field dim_names_2d(1) = "xaxis_1" @@ -4674,6 +4674,868 @@ subroutine gfdl_diag_register(Time, Sfcprop, Gfs_diag, Cldprop, & Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%sr(:) enddo +#ifdef USE_COSP +!--- 2D diagnostic variables from the CFMIP Observation Simulator Package (COSP), Linjiong Zhou + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cltisccp' + Diag(idx)%desc = 'ISCCP Total Cloud Fraction / cloud_area_fraction' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%cltisccp(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'meantbisccp' + Diag(idx)%desc = 'ISCCP all-sky 10.5 micron brightness temperature / toa_brightness_temperature' + Diag(idx)%unit = 'K' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%meantbisccp(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'meantbclrisccp' + Diag(idx)%desc = 'ISCCP clear-sky 10.5 micron brightness temperature / toa_brightness_temperature_assuming_clear_sky' + Diag(idx)%unit = 'K' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%meantbclrisccp(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'pctisccp' + Diag(idx)%desc = 'ISCCP Mean Cloud Top Pressure / air_pressure_at_cloud_top' + Diag(idx)%unit = 'hPa' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%pctisccp(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'tauisccp' + Diag(idx)%desc = 'ISCCP Mean Optical Depth / atmosphere_optical_thickness_due_to_cloud' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%tauisccp(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'albisccp' + Diag(idx)%desc = 'ISCCP Mean Cloud Albedo / cloud_albedo' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%albisccp(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'misr_meanztop' + Diag(idx)%desc = 'MISR Mean Cloud Top Height / cloud_top_altitude' + Diag(idx)%unit = 'm' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%misr_meanztop(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'misr_cldarea' + Diag(idx)%desc = 'MISR cloud cover / cloud_area_fraction' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%misr_cldarea(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cltmodis' + Diag(idx)%desc = 'MODIS Total Cloud Fraction / cloud_area_fraction' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%cltmodis(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clwmodis' + Diag(idx)%desc = 'MODIS Liquid Cloud Fraction / cloud_area_fraction' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clwmodis(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'climodis' + Diag(idx)%desc = 'MODIS Ice Cloud Fraction / cloud_area_fraction' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%climodis(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clhmodis' + Diag(idx)%desc = 'MODIS High Level Cloud Fraction / cloud_area_fraction_in_atmosphere_layer' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clhmodis(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clmmodis' + Diag(idx)%desc = 'MODIS Mid Level Cloud Fraction / cloud_area_fraction_in_atmosphere_layer' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clmmodis(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cllmodis' + Diag(idx)%desc = 'MODIS Low Level Cloud Fraction / cloud_area_fraction_in_atmosphere_layer' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%cllmodis(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'tautmodis' + Diag(idx)%desc = 'MODIS Total Cloud Optical Thickness / atmosphere_optical_thickness_due_to_cloud' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%tautmodis(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'tauwmodis' + Diag(idx)%desc = 'MODIS Liquid Cloud Optical Thickness / atmosphere_optical_thickness_due_to_cloud' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%tauwmodis(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'tauimodis' + Diag(idx)%desc = 'MODIS Ice Cloud Optical Thickness / atmosphere_optical_thickness_due_to_cloud' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%tauimodis(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'tautlogmodis' + Diag(idx)%desc = 'MODIS Total Cloud Optical Thickness (Log10 Mean) / atmosphere_optical_thickness_due_to_cloud' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%tautlogmodis(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'tauwlogmodis' + Diag(idx)%desc = 'MODIS Liquid Cloud Optical Thickness (Log10 Mean) / atmosphere_optical_thickness_due_to_cloud' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%tauwlogmodis(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'tauilogmodis' + Diag(idx)%desc = 'MODIS Ice Cloud Optical Thickness (Log10 Mean) / atmosphere_optical_thickness_due_to_cloud' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%tauilogmodis(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'reffclwmodis' + Diag(idx)%desc = 'MODIS Liquid Cloud Particle Size / effective_radius_of_cloud_liquid_water_particle' + Diag(idx)%unit = 'm' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%reffclwmodis(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'reffclimodis' + Diag(idx)%desc = 'MODIS Ice Cloud Particle Size / effective_radius_of_cloud_liquid_water_particle' + Diag(idx)%unit = 'm' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%reffclimodis(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'pctmodis' + Diag(idx)%desc = 'MODIS Cloud Top Pressure / air_pressure_at_cloud_top' + Diag(idx)%unit = 'hPa' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%pctmodis(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'lwpmodis' + Diag(idx)%desc = 'MODIS Cloud Liquid Water Path / atmosphere_cloud_liquid_water_content' + Diag(idx)%unit = 'kg m-2' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%lwpmodis(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'iwpmodis' + Diag(idx)%desc = 'MODIS Cloud Ice Water Path / atmosphere_mass_content_of_cloud_ice' + Diag(idx)%unit = 'kg m-2' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%iwpmodis(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cltlidarradar' + Diag(idx)%desc = 'CALIPSO and CloudSat Total Cloud Fraction / cloud_area_fraction' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%cltlidarradar(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cllcalipsoice' + Diag(idx)%desc = 'CALIPSO Ice Low Cloud Fraction / cloud_area_fraction_in_atmosphere_layer' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%cllcalipsoice(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clmcalipsoice' + Diag(idx)%desc = 'CALIPSO Ice Mid Cloud Fraction / cloud_area_fraction_in_atmosphere_layer' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clmcalipsoice(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clhcalipsoice' + Diag(idx)%desc = 'CALIPSO Ice High Cloud Fraction / cloud_area_fraction_in_atmosphere_layer' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clhcalipsoice(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cltcalipsoice' + Diag(idx)%desc = 'CALIPSO Ice Total Cloud Fraction / cloud_area_fraction' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%cltcalipsoice(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cllcalipsoliq' + Diag(idx)%desc = 'CALIPSO Liquid Low Cloud Fraction / cloud_area_fraction_in_atmosphere_layer' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%cllcalipsoliq(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clmcalipsoliq' + Diag(idx)%desc = 'CALIPSO Liquid Mid Cloud Fraction / cloud_area_fraction_in_atmosphere_layer' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clmcalipsoliq(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clhcalipsoliq' + Diag(idx)%desc = 'CALIPSO Liquid High Cloud Fraction / cloud_area_fraction_in_atmosphere_layer' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clhcalipsoliq(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cltcalipsoliq' + Diag(idx)%desc = 'CALIPSO Liquid Total Cloud Fraction / cloud_area_fraction' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%cltcalipsoliq(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cllcalipsoun' + Diag(idx)%desc = 'CALIPSO Undefined-Phase Low Level Cloud Fraction / cloud_area_fraction_in_atmosphere_layer' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%cllcalipsoun(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clmcalipsoun' + Diag(idx)%desc = 'CALIPSO Undefined-Phase Mid Level Cloud Fraction / cloud_area_fraction_in_atmosphere_layer' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clmcalipsoun(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clhcalipsoun' + Diag(idx)%desc = 'CALIPSO Undefined-Phase High Level Cloud Fraction / cloud_area_fraction_in_atmosphere_layer' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clhcalipsoun(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cltcalipsoun' + Diag(idx)%desc = 'CALIPSO Undefined-Phase Total Cloud Fraction / cloud_area_fraction' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%cltcalipsoun(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cllcalipso' + Diag(idx)%desc = 'CALIPSO Low Level Cloud Fraction / cloud_area_fraction_in_atmosphere_layer' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%cllcalipso(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clmcalipso' + Diag(idx)%desc = 'CALIPSO Mid Level Cloud Fraction / cloud_area_fraction_in_atmosphere_layer' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clmcalipso(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clhcalipso' + Diag(idx)%desc = 'CALIPSO High Level Cloud Fraction / cloud_area_fraction_in_atmosphere_layer' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clhcalipso(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cltcalipso' + Diag(idx)%desc = 'CALIPSO Total Cloud Fraction / cloud_area_fraction' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%cltcalipso(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clopaquecalipso' + Diag(idx)%desc = 'CALIPSO Opaque Cloud Cover / opaque_cloud_cover' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clopaquecalipso(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clthincalipso' + Diag(idx)%desc = 'CALIPSO Thin Cloud Cover / thin_cloud_cover' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clthincalipso(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clzopaquecalipso' + Diag(idx)%desc = 'CALIPSO z_opaque Altitude / z_opaque' + Diag(idx)%unit = 'm' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clzopaquecalipso(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clopaquetemp' + Diag(idx)%desc = 'CALIPSO Opaque Cloud Temperature / opaque_cloud_temperature' + Diag(idx)%unit = 'K' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clopaquetemp(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clthintemp' + Diag(idx)%desc = 'CALIPSO Thin Cloud Temperature / thin_cloud_temperature' + Diag(idx)%unit = 'K' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clthintemp(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clzopaquetemp' + Diag(idx)%desc = 'CALIPSO z_opaque Temperature / z_opaque_temperature' + Diag(idx)%unit = 'K' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clzopaquetemp(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clopaquemeanz' + Diag(idx)%desc = 'CALIPSO Opaque Cloud Altitude / opaque_cloud_altitude' + Diag(idx)%unit = 'm' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clopaquemeanz(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clthinmeanz' + Diag(idx)%desc = 'CALIPSO Thin Cloud Altitude / thin_cloud_altitude' + Diag(idx)%unit = 'm' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clthinmeanz(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clthinemis' + Diag(idx)%desc = 'CALIPSO Thin Cloud Emissivity / thin_cloud_emissivity' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clthinemis(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clopaquemeanzse' + Diag(idx)%desc = 'CALIPSO Opaque Cloud Altitude with respect to SE / opaque_cloud_altitude_se' + Diag(idx)%unit = 'm' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clopaquemeanzse(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clthinmeanzse' + Diag(idx)%desc = 'CALIPSO Thin Cloud Altitude with respect to SE / thin_cloud_altitude_se' + Diag(idx)%unit = 'm' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clthinmeanzse(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clzopaquecalipsose' + Diag(idx)%desc = 'CALIPSO z_opaque Altitude with respect to SE / z_opaque_se' + Diag(idx)%unit = 'm' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clzopaquecalipsose(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cllgrLidar532' + Diag(idx)%desc = 'GROUND LIDAR Low Level Cloud Cover / grLidar532_low_cloud_cover' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%cllgrLidar532(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clmgrLidar532' + Diag(idx)%desc = 'GROUND LIDAR Mid Level Cloud Cover / grLidar532_mid_cloud_cover' + Diag(idx)%unit = 'm' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clmgrLidar532(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clhgrLidar532' + Diag(idx)%desc = 'GROUND LIDAR High Level Cloud Cover / grLidar532_high_cloud_cover' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clhgrLidar532(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cltgrLidar532' + Diag(idx)%desc = 'GROUND LIDAR Total Cloud Cover / grLidar532_total_cloud_cover' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%cltgrLidar532(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cllatlid' + Diag(idx)%desc = 'ATLID Low Level Cloud Cover / atlid_low_cloud_cover' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%cllatlid(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clmatlid' + Diag(idx)%desc = 'ATLID Mid Level Cloud Cover / atlid_mid_cloud_cover' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clmatlid(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'clhatlid' + Diag(idx)%desc = 'ATLID High Level Cloud Cover / atlid_high_cloud_cover' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%clhatlid(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cltatlid' + Diag(idx)%desc = 'ATLID Total Cloud Cover / atlid_total_cloud_cover' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%cltatlid(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'ptcloudsatflag0' + Diag(idx)%desc = 'Cloudsat precipitation cover for flag0' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%ptcloudsatflag0(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'ptcloudsatflag1' + Diag(idx)%desc = 'Cloudsat precipitation cover for flag1' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%ptcloudsatflag1(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'ptcloudsatflag2' + Diag(idx)%desc = 'Cloudsat precipitation cover for flag2' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%ptcloudsatflag2(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'ptcloudsatflag3' + Diag(idx)%desc = 'Cloudsat precipitation cover for flag3' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%ptcloudsatflag3(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'ptcloudsatflag4' + Diag(idx)%desc = 'Cloudsat precipitation cover for flag4' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%ptcloudsatflag4(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'ptcloudsatflag5' + Diag(idx)%desc = 'Cloudsat precipitation cover for flag5' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%ptcloudsatflag5(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'ptcloudsatflag6' + Diag(idx)%desc = 'Cloudsat precipitation cover for flag6' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%ptcloudsatflag6(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'ptcloudsatflag7' + Diag(idx)%desc = 'Cloudsat precipitation cover for flag7' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%ptcloudsatflag7(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'ptcloudsatflag8' + Diag(idx)%desc = 'Cloudsat precipitation cover for flag8' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%ptcloudsatflag8(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'ptcloudsatflag9' + Diag(idx)%desc = 'Cloudsat precipitation cover for flag9' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%ptcloudsatflag9(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cloudsatpia' + Diag(idx)%desc = 'Cloudsat path integrated attenuation' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%cloudsatpia(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cloudsat_tcc' + Diag(idx)%desc = 'CloudSat Total Cloud Fraction / cloud_area_fraction' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%cloudsat_tcc(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cloudsat_tcc2' + Diag(idx)%desc = 'CloudSat Total Cloud Fraction (no 1km) / cloud_area_fraction' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%cloudsat_tcc2(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'npdfcld' + Diag(idx)%desc = '# of Non-Precipitating Clouds / number_of_slwc_nonprecip' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%npdfcld(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'npdfdrz' + Diag(idx)%desc = '# of Drizzling Clouds / number_of_slwc_drizzle' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%npdfdrz(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'npdfrain' + Diag(idx)%desc = '# of Precipitating Clouds / number_of_slwc_precip' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%npdfrain(:) + enddo +#endif + ! idx = idx + 1 ! Diag(idx)%axes = 2 ! Diag(idx)%name = 'crain_ave' @@ -5486,6 +6348,7 @@ subroutine gfdl_diag_register(Time, Sfcprop, Gfs_diag, Cldprop, & Diag(idx)%desc = 'restoring flux' Diag(idx)%unit = 'W/m**2' Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. Diag(idx)%coarse_graining_method = AREA_WEIGHTED Diag(idx)%time_avg = .TRUE. allocate (Diag(idx)%data(nblks)) @@ -5733,7 +6596,7 @@ subroutine gfdl_diag_output(Time, Atm_block, IPD_Data, nx, ny, fprint, & character(len=2) :: xtra real(kind=kind_phys), dimension(nx*ny) :: var2p real(kind=kind_phys), dimension(nx*ny,levs) :: var3p - real(kind=kind_phys), dimension(nx,ny) :: var2, area, lat, lon, one, landmask, seamask + real(kind=kind_phys), dimension(nx,ny) :: var2, area, lat, lon, one, landmask, seamask, icemask real(kind=kind_phys), dimension(nx,ny,levs) :: var3 real(kind=kind_phys) :: rdt, rtime_int, rtime_intfull, lcnvfac real(kind=kind_phys) :: rtime_radsw, rtime_radlw @@ -5769,6 +6632,7 @@ subroutine gfdl_diag_output(Time, Atm_block, IPD_Data, nx, ny, fprint, & one(i,j) = 1. landmask(i,j) = IPD_Data(nb)%Sfcprop%slmsk(ix) seamask(i,j) = 1. - landmask(i,j) + icemask(i,j) = landmask(i,j) - 1. enddo enddo @@ -5888,31 +6752,111 @@ subroutine gfdl_diag_output(Time, Atm_block, IPD_Data, nx, ny, fprint, & endif !!!! Accumulated diagnostics --- lmh 19 sep 17 - if (fprint .or. prt_stats) then + if (fprint .and. prt_stats) then select case (trim(Diag(idx)%name)) - case('totprcp_ave') + case('totprcpb_ave') call prt_gb_nh_sh_us('Total Precip (mm/d)', 1, nx, 1, ny, var2, area, lon, lat, one, 86400.) call prt_gb_nh_sh_us('Land Precip (mm/d)', 1, nx, 1, ny, var2, area, lon, lat, landmask, 86400.) - case('totsnw') + call prt_gb_nh_sh_us('Ocean Precip (mm/d)', 1, nx, 1, ny, var2, area, lon, lat, seamask, 86400.) + call prt_gb_nh_sh_us('SeaIce Precip (mm/d)', 1, nx, 1, ny, var2, area, lon, lat, icemask, 86400.) + case('cnvprcpb_ave') + call prt_gb_nh_sh_us('Total Convective Precip (mm/d)', 1, nx, 1, ny, var2, area, lon, lat, one, 86400.) + call prt_gb_nh_sh_us('Land Convective Precip (mm/d)', 1, nx, 1, ny, var2, area, lon, lat, landmask, 86400.) + call prt_gb_nh_sh_us('Ocean Convective Precip (mm/d)', 1, nx, 1, ny, var2, area, lon, lat, seamask, 86400.) + call prt_gb_nh_sh_us('SeaIce Convective Precip (mm/d)', 1, nx, 1, ny, var2, area, lon, lat, icemask, 86400.) + case('totsnwb_ave') call prt_gb_nh_sh_us('Total Snowfall (9:1 mm/d)', 1, nx, 1, ny, var2, area, lon, lat, one, 777600.) call prt_gb_nh_sh_us('Land Snowfall (9:1 mm/d)', 1, nx, 1, ny, var2, area, lon, lat, landmask, 777600.) + call prt_gb_nh_sh_us('Ocean Snowfall (9:1 mm/d)', 1, nx, 1, ny, var2, area, lon, lat, seamask, 777600.) + call prt_gb_nh_sh_us('SeaIce Snowfall (9:1 mm/d)', 1, nx, 1, ny, var2, area, lon, lat, icemask, 777600.) ! case('totgrp') ! Tiny?? ! call prt_gb_nh_sh_us('Total Icefall (2:1 mm/d)', 1, nx, 1, ny, var2, area, lon, lat, one, 172800.) ! call prt_gb_nh_sh_us('Land Icefall (2:1 mm/d)', 1, nx, 1, ny, var2, area, lon, lat, landmask, 172800.) +! call prt_gb_nh_sh_us('Ocean Icefall (2:1 mm/d)', 1, nx, 1, ny, var2, area, lon, lat, seamask, 172800.) +! call prt_gb_nh_sh_us('SeaIce Icefall (2:1 mm/d)', 1, nx, 1, ny, var2, area, lon, lat, icemask, 172800.) case('lhtfl_ave') - call prt_gb_nh_sh_us('Total sfc LH flux ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) + call prt_gb_nh_sh_us('Total sfc LH flux ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) + call prt_gb_nh_sh_us('Land sfc LH flux ', 1, nx, 1, ny, var2, area, lon, lat, landmask, 1.) + call prt_gb_nh_sh_us('Ocean sfc LH flux ', 1, nx, 1, ny, var2, area, lon, lat, seamask, 1.) + call prt_gb_nh_sh_us('SeaIce sfc LH flux ', 1, nx, 1, ny, var2, area, lon, lat, icemask, 1.) case('shtfl_ave') - call prt_gb_nh_sh_us('Total sfc SH flux ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) + call prt_gb_nh_sh_us('Total sfc SH flux ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) + call prt_gb_nh_sh_us('Land sfc SH flux ', 1, nx, 1, ny, var2, area, lon, lat, landmask, 1.) + call prt_gb_nh_sh_us('Ocean sfc SH flux ', 1, nx, 1, ny, var2, area, lon, lat, seamask, 1.) + call prt_gb_nh_sh_us('SeaIce sfc SH flux ', 1, nx, 1, ny, var2, area, lon, lat, icemask, 1.) + case('hpbl') + call prt_gb_nh_sh_us('Total pbl height ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) + call prt_gb_nh_sh_us('Land pbl height ', 1, nx, 1, ny, var2, area, lon, lat, landmask, 1.) + call prt_gb_nh_sh_us('Ocean pbl height ', 1, nx, 1, ny, var2, area, lon, lat, seamask, 1.) + call prt_gb_nh_sh_us('SeaIce pbl height ', 1, nx, 1, ny, var2, area, lon, lat, icemask, 1.) + case('dusfc') + call prt_gb_nh_sh_us('Total u-wind stress ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) + call prt_gb_nh_sh_us('Land u-wind stress ', 1, nx, 1, ny, var2, area, lon, lat, landmask, 1.) + call prt_gb_nh_sh_us('Ocean u-wind stress ', 1, nx, 1, ny, var2, area, lon, lat, seamask, 1.) + call prt_gb_nh_sh_us('SeaIce u-wind stress ', 1, nx, 1, ny, var2, area, lon, lat, icemask, 1.) + case('dvsfc') + call prt_gb_nh_sh_us('Total v-wind stress ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) + call prt_gb_nh_sh_us('Land v-wind stress ', 1, nx, 1, ny, var2, area, lon, lat, landmask, 1.) + call prt_gb_nh_sh_us('Ocean v-wind stress ', 1, nx, 1, ny, var2, area, lon, lat, seamask, 1.) + call prt_gb_nh_sh_us('SeaIce v-wind stress ', 1, nx, 1, ny, var2, area, lon, lat, icemask, 1.) case('DSWRFtoa') call prt_gb_nh_sh_us('TOA SW down ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) case('USWRFtoa') call prt_gb_nh_sh_us('TOA SW up ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) case('ULWRFtoa') call prt_gb_nh_sh_us('TOA LW up ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) + case('u10m') + call prt_gb_nh_sh_us('Total 10-m u avg ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) + call prt_gb_nh_sh_us('Land 10-m u avg ', 1, nx, 1, ny, var2, area, lon, lat, landmask, 1.) + call prt_gb_nh_sh_us('Ocean 10-m u avg ', 1, nx, 1, ny, var2, area, lon, lat, seamask, 1.) + call prt_gb_nh_sh_us('SeaIce 10-m u avg ', 1, nx, 1, ny, var2, area, lon, lat, icemask, 1.) + case('v10m') + call prt_gb_nh_sh_us('Total 10-m v avg ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) + call prt_gb_nh_sh_us('Land 10-m v avg ', 1, nx, 1, ny, var2, area, lon, lat, landmask, 1.) + call prt_gb_nh_sh_us('Ocean 10-m v avg ', 1, nx, 1, ny, var2, area, lon, lat, seamask, 1.) + call prt_gb_nh_sh_us('SeaIce 10-m v avg ', 1, nx, 1, ny, var2, area, lon, lat, icemask, 1.) + case('acond') + call prt_gb_nh_sh_us('Total momentum exchange coefficient ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) + call prt_gb_nh_sh_us('Land momentum exchange coefficient ', 1, nx, 1, ny, var2, area, lon, lat, landmask, 1.) + call prt_gb_nh_sh_us('Ocean momentum exchange coefficient ', 1, nx, 1, ny, var2, area, lon, lat, seamask, 1.) + call prt_gb_nh_sh_us('SeaIce momentum exchange coefficient ', 1, nx, 1, ny, var2, area, lon, lat, icemask, 1.) + case('sfexc') + call prt_gb_nh_sh_us('Total thermal exchange coefficient ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) + call prt_gb_nh_sh_us('Land thermal exchange coefficient ', 1, nx, 1, ny, var2, area, lon, lat, landmask, 1.) + call prt_gb_nh_sh_us('Ocean thermal exchange coefficient ', 1, nx, 1, ny, var2, area, lon, lat, seamask, 1.) + call prt_gb_nh_sh_us('SeaIce thermal exchange coefficient ', 1, nx, 1, ny, var2, area, lon, lat, icemask, 1.) + case('ffmm') + call prt_gb_nh_sh_us('Total ffmm for PBL ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) + call prt_gb_nh_sh_us('Land ffmm for PBL ', 1, nx, 1, ny, var2, area, lon, lat, landmask, 1.) + call prt_gb_nh_sh_us('Ocean ffmm for PBL ', 1, nx, 1, ny, var2, area, lon, lat, seamask, 1.) + call prt_gb_nh_sh_us('SeaIce ffmm for PBL ', 1, nx, 1, ny, var2, area, lon, lat, icemask, 1.) + case('ffhh') + call prt_gb_nh_sh_us('Total ffhh for PBL ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) + call prt_gb_nh_sh_us('Land ffhh for PBL ', 1, nx, 1, ny, var2, area, lon, lat, landmask, 1.) + call prt_gb_nh_sh_us('Ocean ffhh for PBL ', 1, nx, 1, ny, var2, area, lon, lat, seamask, 1.) + call prt_gb_nh_sh_us('SeaIce ffhh for PBL ', 1, nx, 1, ny, var2, area, lon, lat, icemask, 1.) + case('ZORLsfc') + call prt_gb_nh_sh_us('Total surface roughness ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) + call prt_gb_nh_sh_us('Land surface roughness ', 1, nx, 1, ny, var2, area, lon, lat, landmask, 1.) + call prt_gb_nh_sh_us('Ocean surface roughness ', 1, nx, 1, ny, var2, area, lon, lat, seamask, 1.) + call prt_gb_nh_sh_us('SeaIce surface roughness ', 1, nx, 1, ny, var2, area, lon, lat, icemask, 1.) + case('q2m') + call prt_gb_nh_sh_us('Total 2-m Q avg ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) + call prt_gb_nh_sh_us('Land 2-m Q avg ', 1, nx, 1, ny, var2, area, lon, lat, landmask, 1.) + call prt_gb_nh_sh_us('Ocean 2-m Q avg ', 1, nx, 1, ny, var2, area, lon, lat, seamask, 1.) + call prt_gb_nh_sh_us('SeaIce 2-m Q avg ', 1, nx, 1, ny, var2, area, lon, lat, icemask, 1.) case('t2m') + call prt_gb_nh_sh_us('Total 2-m T avg ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) + call prt_gb_nh_sh_us('Land 2-m T avg ', 1, nx, 1, ny, var2, area, lon, lat, landmask, 1.) + call prt_gb_nh_sh_us('Ocean 2-m T avg ', 1, nx, 1, ny, var2, area, lon, lat, seamask, 1.) + call prt_gb_nh_sh_us('SeaIce 2-m T avg ', 1, nx, 1, ny, var2, area, lon, lat, icemask, 1.) call prt_gb_nh_sh_us('2-m T max ', 1, nx, 1, ny, var2, area, lon, lat, one, 1., 'MAX') call prt_gb_nh_sh_us('2-m T min ', 1, nx, 1, ny, var2, area, lon, lat, one, 1., 'MIN') case('tsfc') + call prt_gb_nh_sh_us('Total sfc T avg ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) + call prt_gb_nh_sh_us('Land sfc T avg ', 1, nx, 1, ny, var2, area, lon, lat, landmask, 1.) + call prt_gb_nh_sh_us('Ocean sfc T avg ', 1, nx, 1, ny, var2, area, lon, lat, seamask, 1.) + call prt_gb_nh_sh_us('SeaIce sfc T avg ', 1, nx, 1, ny, var2, area, lon, lat, icemask, 1.) call prt_gb_nh_sh_us('sfc T max ', 1, nx, 1, ny, var2, area, lon, lat, one, 1., 'MAX') call prt_gb_nh_sh_us('sfc T min ', 1, nx, 1, ny, var2, area, lon, lat, one, 1., 'MIN') call prt_gb_nh_sh_us('SST max ', 1, nx, 1, ny, var2, area, lon, lat, seamask, 1., 'MAX') diff --git a/GFS_layer/GFS_abstraction_layer.F90 b/GFS_layer/GFS_abstraction_layer.F90 index b8e6d890..f7ef24df 100644 --- a/GFS_layer/GFS_abstraction_layer.F90 +++ b/GFS_layer/GFS_abstraction_layer.F90 @@ -16,7 +16,8 @@ module physics_abstraction_layer time_vary_step => GFS_time_vary_step, & radiation_step1 => GFS_radiation_driver, & physics_step1 => GFS_physics_driver, & - physics_step2 => GFS_stochastic_driver + physics_step2 => GFS_stochastic_driver,& + physics_end => GFS_physics_end !---------------------- ! public physics types @@ -41,6 +42,7 @@ module physics_abstraction_layer public radiation_step1 public physics_step1 public physics_step2 + public physics_end CONTAINS diff --git a/GFS_layer/GFS_driver.F90 b/GFS_layer/GFS_driver.F90 index d28cdb74..eb9448cc 100644 --- a/GFS_layer/GFS_driver.F90 +++ b/GFS_layer/GFS_driver.F90 @@ -12,12 +12,12 @@ module GFS_driver use module_radsw_parameters, only: topfsw_type, sfcfsw_type use module_radlw_parameters, only: topflw_type, sfcflw_type use funcphys, only: gfuncphys - use gfdl_cld_mp_mod, only: gfdl_cld_mp_init -#ifndef fvGFS_2017 - use cld_eff_rad_mod, only: cld_eff_rad_init -#endif + use gfdl_cld_mp_mod, only: gfdl_cld_mp_init, gfdl_cld_mp_end use myj_pbl_mod, only: myj_pbl_init use myj_jsfc_mod, only: myj_jsfc_init +#ifdef USE_COSP + use cosp2_test, only: cosp2_init, cosp2_end +#endif implicit none @@ -94,6 +94,7 @@ module GFS_driver public GFS_radiation_driver !< radiation_driver (was grrad) public GFS_physics_driver !< physics_driver (was gbphys) public GFS_stochastic_driver !< stochastic physics + public GFS_physics_end !< GFS physics end routine CONTAINS @@ -216,11 +217,8 @@ subroutine GFS_initialize (Model, Statein, Stateout, Sfcprop, & endif !--- initialize GFDL Cloud microphysics - if (.not. Model%do_inline_mp .and. Model%ncld == 5) then - call gfdl_cld_mp_init (Model%input_nml_file, Init_parm%logunit) -#ifndef fvGFS_2017 - call cld_eff_rad_init (Model%input_nml_file, Init_parm%logunit) -#endif + if (Model%ncld == 5) then + call gfdl_cld_mp_init (Model%input_nml_file, Init_parm%logunit, Statein(1)%dycore_hydrostatic) endif !--- initialize ras @@ -255,6 +253,20 @@ subroutine GFS_initialize (Model, Statein, Stateout, Sfcprop, & !--- this note is placed here alertng users to study !--- the FV3GFS_io.F90 module +#ifdef USE_COSP +!----------------------------------------------------------------------- +! The CFMIP Observation Simulator Package (COSP) +! Added by Linjiong Zhou +! May 2021 +!----------------------------------------------------------------------- + + if (Model%do_cosp) then + do nb = 1, nblks + call cosp2_init (size(Grid(nb)%xlon,1), Model%levs) + enddo + endif +#endif + end subroutine GFS_initialize @@ -545,6 +557,31 @@ subroutine GFS_stochastic_driver (Model, Statein, Stateout, Sfcprop, Coupling, & end subroutine GFS_stochastic_driver +!-------------- +! GFS physics end +!-------------- + subroutine GFS_physics_end (Model) + + implicit none + + !--- interface variables + type(GFS_control_type), intent(inout) :: Model + + call gfdl_cld_mp_end () + +#ifdef USE_COSP +!----------------------------------------------------------------------- +! The CFMIP Observation Simulator Package (COSP) +! Added by Linjiong Zhou +! May 2021 +!----------------------------------------------------------------------- + + if (Model%do_cosp) then + call cosp2_end () + endif +#endif + + end subroutine GFS_physics_end !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/GFS_layer/GFS_physics_driver.F90 b/GFS_layer/GFS_physics_driver.F90 index fc3d559e..57883d3b 100644 --- a/GFS_layer/GFS_physics_driver.F90 +++ b/GFS_layer/GFS_physics_driver.F90 @@ -15,7 +15,7 @@ module module_physics_driver GFS_control_type, GFS_grid_type, & GFS_tbd_type, GFS_cldprop_type, & GFS_radtend_type, GFS_diag_type - use gfdl_cld_mp_mod, only: gfdl_cld_mp_driver + use gfdl_cld_mp_mod, only: gfdl_cld_mp_driver, c_liq, c_ice use funcphys, only: ftdp use module_ocean, only: update_ocean use myj_pbl_mod, only: myj_pbl @@ -23,6 +23,9 @@ module module_physics_driver use wv_saturation, only: estblf use module_sfc_drv, only: sfc_drv +#ifdef USE_COSP + use cosp2_test, only: cosp2_driver +#endif implicit none @@ -448,7 +451,7 @@ subroutine GFS_physics_driver & dtshoc, & !--- GFDL Cloud microphysics crain, csnow, & - z0fun, diag_rain, diag_rain1 + z0fun, diag_water, diag_rain, diag_rain1 real(kind=kind_phys), dimension(Model%ntrac-Model%ncld+2) :: & fscav, fswtr @@ -484,12 +487,12 @@ subroutine GFS_physics_driver & #ifdef fvGFS_2017 real(kind=kind_phys), dimension(size(Grid%xlon,1),1) :: & - area, land, rain0, snow0, ice0, graupel0, cond0, dep0, & + area, land, water0, rain0, ice0, snow0, graupel0, cond0, dep0,& reevap0, sub0 #else real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: & - gsize, hs, land, rain0, snow0, ice0, graupel0, cond0, dep0, & - reevap0, sub0, zvfun + gsize, hs, land, water0, rain0, ice0, snow0, graupel0, cond0, & + dep0, reevap0, sub0, dte, zvfun #endif real(kind=kind_phys), dimension(size(Grid%xlon,1),4) :: & @@ -501,8 +504,15 @@ subroutine GFS_physics_driver & real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs) :: & del, rhc, dtdt, dudt, dvdt, gwdcu, gwdcv, dtdtc, rainp, & ud_mf, dd_mf, dt_mf, prnum, dkt, flux_cg, flux_en, & + pcw, edw, oew, rrw, tvw, pci, edi, oei, rri, tvi, & + pcr, edr, oer, rrr, tvr, pcs, eds, oes, rrs, tvs, & + pcg, edg, oeg, rrg, tvg, & + prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, & sigmatot, sigmafrac, specific_heat, final_dynamics_delp, dtdt_gwdps + real(kind=kind_phys), allocatable :: & + pfr(:,:), pfs(:,:), pfg(:,:) + !--- GFDL modification for FV3 real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs+1) ::& del_gz @@ -518,7 +528,7 @@ subroutine GFS_physics_driver & real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs) :: & delp, dz, uin, vin, pt, qv1, ql1, qr1, qg1, qa1, qnl1, qi1, & qs1, pt_dt, udt, vdt, w, qv_dt, ql_dt, qr_dt, qi_dt, qni1, & - qs_dt, qg_dt, te, q_con, cappa, & + qs_dt, qg_dt, adj_vmr, te, q_con, cappa, & phmid, th, tke, exner, exchh1, el1 ! for myj #endif @@ -991,6 +1001,8 @@ subroutine GFS_physics_driver & sbsno(:) = 0.0 snowc(:) = 0.0 snohf(:) = 0.0 + qss(:) = 0.0 + gflx(:) = 0.0 Diag%zlvl(:) = Statein%phil(:,1) * onebg Diag%smcwlt2(:) = 0.0 Diag%smcref2(:) = 0.0 @@ -3326,22 +3338,25 @@ subroutine GFS_physics_driver & if (Model%do_inline_mp) then ! GFDL Cloud microphysics tem = dtp * con_p001 / con_day + Statein%prew(:) = Statein%prew(:) * tem Statein%prer(:) = Statein%prer(:) * tem - Statein%pres(:) = Statein%pres(:) * tem Statein%prei(:) = Statein%prei(:) * tem + Statein%pres(:) = Statein%pres(:) * tem Statein%preg(:) = Statein%preg(:) * tem - rain1(:) = Statein%prer(:)+Statein%pres(:)+Statein%prei(:)+Statein%preg(:) + rain1(:) = Statein%prew(:)+Statein%prer(:)+Statein%prei(:)+Statein%pres(:)+Statein%preg(:) Diag%ice(:) = Statein%prei(:) Diag%snow(:) = Statein%pres(:) Diag%graupel(:) = Statein%preg(:) do i = 1, im ! use rainmin following GFS + diag_water = Statein%prew(i) diag_rain = Statein%prer(i) + if(Statein%prew(i) < rainmin) diag_water = zero if(Statein%prer(i) < rainmin) diag_rain = zero if(Statein%prei(i) < rainmin) Diag%ice(i) = zero if(Statein%pres(i) < rainmin) Diag%snow(i) = zero if(Statein%preg(i) < rainmin) Diag%graupel(i) = zero - diag_rain1 = diag_rain + Diag%ice(i) + Diag%snow(i) + Diag%graupel(i) + diag_rain1 = diag_water + diag_rain + Diag%ice(i) + Diag%snow(i) + Diag%graupel(i) if (diag_rain1 > rainmin) then Diag%sr(i) = (Diag%ice(i) + Diag%snow(i) + Diag%graupel(i)) & / diag_rain1 @@ -3355,9 +3370,10 @@ subroutine GFS_physics_driver & #ifdef fvGFS_2017 land (:,1) = frland(:) area (:,1) = Grid%area(:) + water0 (:,1) = 0.0 rain0 (:,1) = 0.0 - snow0 (:,1) = 0.0 ice0 (:,1) = 0.0 + snow0 (:,1) = 0.0 graupel0 (:,1) = 0.0 cond0 (:,1) = 0.0 dep0 (:,1) = 0.0 @@ -3374,6 +3390,11 @@ subroutine GFS_physics_driver & pt_dt (:,1,:) = 0.0 udt (:,1,:) = 0.0 vdt (:,1,:) = 0.0 + prefluxw (:,1,:) = 0.0 + prefluxr (:,1,:) = 0.0 + prefluxi (:,1,:) = 0.0 + prefluxs (:,1,:) = 0.0 + prefluxg (:,1,:) = 0.0 do k = 1, levs qv1 (:,1,k) = Stateout%gq0(:,levs-k+1,1 ) ql1 (:,1,k) = Stateout%gq0(:,levs-k+1,Model%ntcw) @@ -3403,20 +3424,22 @@ subroutine GFS_physics_driver & seconds) tem = dtp * con_p001 / con_day - rain1(:) = (rain0(:,1)+snow0(:,1)+ice0(:,1)+graupel0(:,1)) * tem + rain1(:) = (water0(:,1)+rain0(:,1)+ice0(:,1)+snow0(:,1)+graupel0(:,1)) * tem Diag%ice(:) = ice0 (:,1) * tem Diag%snow(:) = snow0 (:,1) * tem Diag%graupel(:) = graupel0(:,1) * tem do i = 1, im ! use rainmin threshold following GFS + diag_water = water0(i,1) * tem diag_rain = rain0(i,1) * tem + if(diag_water < rainmin) diag_water = zero if(diag_rain < rainmin) diag_rain = zero - if(Diag%snow(i) < rainmin) Diag%snow(i) = zero if(Diag%ice(i) < rainmin) Diag%ice(i) = zero + if(Diag%snow(i) < rainmin) Diag%snow(i) = zero if(Diag%graupel(i) < rainmin) Diag%graupel(i) = zero - diag_rain1 = diag_rain + Diag%snow(i) + Diag%ice(i) + Diag%graupel(i) + diag_rain1 = diag_water + diag_rain + Diag%ice(i) + Diag%snow(i) + Diag%graupel(i) if (diag_rain1 > rainmin) then - Diag%sr(i) = (Diag%snow(i) + Diag%ice(i) + Diag%graupel(i)) & + Diag%sr(i) = (Diag%ice(i) + Diag%snow(i) + Diag%graupel(i)) & / diag_rain1 else Diag%sr(i) = zero @@ -3438,9 +3461,10 @@ subroutine GFS_physics_driver & #else hs = Sfcprop%oro(:) * con_g gsize = sqrt(Grid%area(:)) + water0 = 0.0 rain0 = 0.0 - snow0 = 0.0 ice0 = 0.0 + snow0 = 0.0 graupel0 = 0.0 cond0 = 0.0 dep0 = 0.0 @@ -3448,6 +3472,11 @@ subroutine GFS_physics_driver & sub0 = 0.0 qnl1 = 0.0 qni1 = 0.0 + prefluxw = 0.0 + prefluxr = 0.0 + prefluxi = 0.0 + prefluxs = 0.0 + prefluxg = 0.0 do k = 1, levs w (:,k) = -Statein%vvl(:,levs-k+1)*con_rd*Stateout%gt0(:,levs-k+1) & & /Statein%prsl(:,levs-k+1)/con_g @@ -3460,29 +3489,40 @@ subroutine GFS_physics_driver & Stateout%gq0(:,levs:1:-1,Model%ntsw), Stateout%gq0(:,levs:1:-1,Model%ntgl), & Stateout%gq0(:,levs:1:-1,Model%ntclamt), qnl1(:,levs:1:-1), qni1(:,levs:1:-1), & Stateout%gt0(:,levs:1:-1), w, Stateout%gu0(:,levs:1:-1), & - Stateout%gv0(:,levs:1:-1), dz, delp, gsize, dtp, hs, rain0, snow0, ice0, & + Stateout%gv0(:,levs:1:-1), dz, delp, gsize, dtp, hs, water0, rain0, ice0, snow0, & graupel0, .false., 1, im, 1, levs, q_con(:,levs:1:-1), cappa(:,levs:1:-1), & - .false., te(:,levs:1:-1), cond0, dep0, reevap0, sub0, .true., Model%do_inline_mp) + .false., adj_vmr(:,levs:1:-1), te(:,levs:1:-1), dte, & + pcw(:,levs:1:-1), edw(:,levs:1:-1), oew(:,levs:1:-1), rrw(:,levs:1:-1), tvw(:,levs:1:-1), & + pci(:,levs:1:-1), edi(:,levs:1:-1), oei(:,levs:1:-1), rri(:,levs:1:-1), tvi(:,levs:1:-1), & + pcr(:,levs:1:-1), edr(:,levs:1:-1), oer(:,levs:1:-1), rrr(:,levs:1:-1), tvr(:,levs:1:-1), & + pcs(:,levs:1:-1), eds(:,levs:1:-1), oes(:,levs:1:-1), rrs(:,levs:1:-1), tvs(:,levs:1:-1), & + pcg(:,levs:1:-1), edg(:,levs:1:-1), oeg(:,levs:1:-1), rrg(:,levs:1:-1), tvg(:,levs:1:-1), & + prefluxw(:,levs:1:-1), prefluxr(:,levs:1:-1), & + prefluxi(:,levs:1:-1), prefluxs(:,levs:1:-1), prefluxg(:,levs:1:-1), & + cond0, dep0, reevap0, sub0, .true., Model%do_inline_mp) tem = dtp * con_p001 / con_day + water0(:) = water0(:) * tem rain0(:) = rain0(:) * tem - snow0(:) = snow0(:) * tem ice0(:) = ice0(:) * tem + snow0(:) = snow0(:) * tem graupel0(:) = graupel0(:) * tem - rain1(:) = rain0(:)+snow0(:)+ice0(:)+graupel0(:) + rain1(:) = water0(:)+rain0(:)+ice0(:)+snow0(:)+graupel0(:) Diag%ice(:) = ice0 (:) Diag%snow(:) = snow0 (:) Diag%graupel(:) = graupel0(:) do i = 1, im ! use rainmin threshold following GFS + diag_water = water0(i) diag_rain = rain0(i) + if(water0(i) < rainmin) diag_water = zero if(rain0(i) < rainmin) diag_rain = zero - if(snow0(i) < rainmin) Diag%snow(i) = zero if(ice0(i) < rainmin) Diag%ice(i) = zero + if(snow0(i) < rainmin) Diag%snow(i) = zero if(graupel0(i) < rainmin) Diag%graupel(i) = zero - diag_rain1 = diag_rain + Diag%snow(i) + Diag%ice(i) + Diag%graupel(i) + diag_rain1 = diag_water + diag_rain + Diag%ice(i) + Diag%snow(i) + Diag%graupel(i) if (diag_rain1 > rainmin) then - Diag%sr(i) = (Diag%snow(i) + Diag%ice(i) + Diag%graupel(i)) & + Diag%sr(i) = (Diag%ice(i) + Diag%snow(i) + Diag%graupel(i)) & / diag_rain1 else Diag%sr(i) = zero @@ -3639,14 +3679,14 @@ subroutine GFS_physics_driver & csnow = Diag%rainc(i) endif if (Model%do_inline_mp) then ! GFDL Cloud microphysics - if ((Statein%pres(i)+Statein%prei(i)+Statein%preg(i)+csnow) .gt. (Statein%prer(i)+crain)) then + if ((Statein%prei(i)+Statein%pres(i)+Statein%preg(i)+csnow) .gt. (Statein%prew(i)+Statein%prer(i)+crain)) then Sfcprop%srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1) endif else #ifdef fvGFS_2017 - if ((snow0(i,1)+ice0(i,1)+graupel0(i,1)+csnow) .gt. (rain0(i,1)+crain)) then + if ((ice0(i,1)+snow0(i,1)+graupel0(i,1)+csnow) .gt. (water0(i,1)+rain0(i,1)+crain)) then #else - if ((snow0(i)+ice0(i)+graupel0(i)+csnow) .gt. (rain0(i)+crain)) then + if ((ice0(i)+snow0(i)+graupel0(i)+csnow) .gt. (water0(i)+rain0(i)+crain)) then #endif Sfcprop%srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1) endif @@ -3828,7 +3868,122 @@ subroutine GFS_physics_driver & dq3dt_initial, Diag%dq3dt, Statein%qgrs(:,:,1:nwat), Stateout%gq0(:,:,1:nwat), & final_dynamics_delp, im, levs, nwat, dtp) endif + +#ifdef USE_COSP +!----------------------------------------------------------------------- +! The CFMIP Observation Simulator Package (COSP) +! Added by Linjiong Zhou +! May 2021 +!----------------------------------------------------------------------- + + if (Model%do_cosp) then + + allocate (pfr(ix,levs)) + allocate (pfs(ix,levs)) + allocate (pfg(ix,levs)) + + if (Model%do_inline_mp) then ! GFDL Cloud microphysics + pfr = Statein%prefluxr + pfs = Statein%prefluxs + pfg = Statein%prefluxg + else + pfr = prefluxr + pfs = prefluxs + pfg = prefluxg + endif + + call cosp2_driver (im, levs, Stateout%gt0, Stateout%gq0(:,:,1), Stateout%gu0, & + Stateout%gv0, Statein%prsl, Statein%prsi, Statein%phil, Statein%phii, Sfcprop%tsfc, & + Stateout%gq0(:,:,Model%ntoz), 1-abs(Sfcprop%slmsk-1), Sfcprop%oro, & + Stateout%gq0(:,:,Model%ntclamt), Stateout%gq0(:,:,Model%ntcw), & + Stateout%gq0(:,:,Model%ntiw), pfr, pfs, pfg, model%ncld, diag%reff, & + Radtend%coszen, diag%ctau, & + Diag%cosp%cltisccp, & + Diag%cosp%meantbisccp, & + Diag%cosp%meantbclrisccp, & + Diag%cosp%pctisccp, & + Diag%cosp%tauisccp, & + Diag%cosp%albisccp, & + Diag%cosp%misr_meanztop, & + Diag%cosp%misr_cldarea, & + Diag%cosp%cltmodis, & + Diag%cosp%clwmodis, & + Diag%cosp%climodis, & + Diag%cosp%clhmodis, & + Diag%cosp%clmmodis, & + Diag%cosp%cllmodis, & + Diag%cosp%tautmodis, & + Diag%cosp%tauwmodis, & + Diag%cosp%tauimodis, & + Diag%cosp%tautlogmodis, & + Diag%cosp%tauwlogmodis, & + Diag%cosp%tauilogmodis, & + Diag%cosp%reffclwmodis, & + Diag%cosp%reffclimodis, & + Diag%cosp%pctmodis, & + Diag%cosp%lwpmodis, & + Diag%cosp%iwpmodis, & + Diag%cosp%cltlidarradar, & + Diag%cosp%cllcalipsoice, & + Diag%cosp%clmcalipsoice, & + Diag%cosp%clhcalipsoice, & + Diag%cosp%cltcalipsoice, & + Diag%cosp%cllcalipsoliq, & + Diag%cosp%clmcalipsoliq, & + Diag%cosp%clhcalipsoliq, & + Diag%cosp%cltcalipsoliq, & + Diag%cosp%cllcalipsoun, & + Diag%cosp%clmcalipsoun, & + Diag%cosp%clhcalipsoun, & + Diag%cosp%cltcalipsoun, & + Diag%cosp%cllcalipso, & + Diag%cosp%clmcalipso, & + Diag%cosp%clhcalipso, & + Diag%cosp%cltcalipso, & + Diag%cosp%clopaquecalipso, & + Diag%cosp%clthincalipso, & + Diag%cosp%clzopaquecalipso, & + Diag%cosp%clopaquetemp, & + Diag%cosp%clthintemp, & + Diag%cosp%clzopaquetemp, & + Diag%cosp%clopaquemeanz, & + Diag%cosp%clthinmeanz, & + Diag%cosp%clthinemis, & + Diag%cosp%clopaquemeanzse, & + Diag%cosp%clthinmeanzse, & + Diag%cosp%clzopaquecalipsose, & + Diag%cosp%cllgrLidar532, & + Diag%cosp%clmgrLidar532, & + Diag%cosp%clhgrLidar532, & + Diag%cosp%cltgrLidar532, & + Diag%cosp%cllatlid, & + Diag%cosp%clmatlid, & + Diag%cosp%clhatlid, & + Diag%cosp%cltatlid, & + Diag%cosp%ptcloudsatflag0, & + Diag%cosp%ptcloudsatflag1, & + Diag%cosp%ptcloudsatflag2, & + Diag%cosp%ptcloudsatflag3, & + Diag%cosp%ptcloudsatflag4, & + Diag%cosp%ptcloudsatflag5, & + Diag%cosp%ptcloudsatflag6, & + Diag%cosp%ptcloudsatflag7, & + Diag%cosp%ptcloudsatflag8, & + Diag%cosp%ptcloudsatflag9, & + Diag%cosp%cloudsatpia, & + Diag%cosp%cloudsat_tcc, & + Diag%cosp%cloudsat_tcc2, & + Diag%cosp%npdfcld, & + Diag%cosp%npdfdrz, & + Diag%cosp%npdfrain) + deallocate (pfr) + deallocate (pfs) + deallocate (pfg) + + endif +#endif + return !................................... end subroutine GFS_physics_driver @@ -3895,8 +4050,6 @@ subroutine moist_cv_nwat6(initial_dynamics_q, physics_q, pressure_on_interfaces, real(kind=kind_phys) :: cv_air = con_cp - con_rd ! From fv_mapz.F90 real(kind=kind_phys) :: cv_vap = 3.0 * con_rv ! From fv_mapz.F90 - real(kind=kind_phys) :: c_liq = 4.1855e+3 ! Hard-coded in fv_mapz.F90 - real(kind=kind_phys) :: c_ice = 1972.0 ! Hard-coded in fv_mapz.F90 ! fv_mapz.moist_cv defines branches for using other moist tracer configurations. ! For simplicity we choose not to replicate that behavior here, since we have @@ -3941,8 +4094,6 @@ subroutine moist_cp_nwat6(initial_dynamics_q, physics_q, pressure_on_interfaces, real(kind=kind_phys) :: cp_air = con_cp ! From fv_mapz.F90 real(kind=kind_phys) :: cp_vap = con_cvap ! From fv_mapz.F90 - real(kind=kind_phys) :: c_liq = 4.1855e+3 ! Hard-coded in fv_mapz.F90 - real(kind=kind_phys) :: c_ice = 1972.0 ! Hard-coded in fv_mapz.F90 ! fv_mapz.moist_cp defines branches for using other moist tracer configurations. ! For simplicity we choose not to replicate that behavior here, since we have diff --git a/GFS_layer/GFS_radiation_driver.F90 b/GFS_layer/GFS_radiation_driver.F90 index 7b53a800..32cfe0b9 100644 --- a/GFS_layer/GFS_radiation_driver.F90 +++ b/GFS_layer/GFS_radiation_driver.F90 @@ -1212,7 +1212,7 @@ subroutine GFS_radiation_driver & real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP) :: & htswc, htlwc, gcice, grain, grime, htsw0, htlw0, plyr, tlyr, & qlyr, olyr, rhly, tvly,qstl, vvel, clw, ciw, prslk1, tem2da, & - tem2db, cldcov, deltaq, cnvc, cnvw + tem2db, cldcov, deltaq, cnvc, cnvw, qa, tau067, tau110 real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+1+LTP) :: plvl, tlvl @@ -1354,6 +1354,7 @@ subroutine GFS_radiation_driver & call coszmn (Grid%xlon,Grid%sinlat, & ! --- inputs Grid%coslat,Model%solhr, IM, me, & Model%daily_mean, & + Model%fixed_sollat, Model%sollat,& Radtend%coszen, Radtend%coszdg) ! --- outputs endif @@ -1594,13 +1595,18 @@ subroutine GFS_radiation_driver & Sfcprop%slmsk, tracer1(:,1:lmk,Model%ntclamt),& im, lmk, lmp, clouds, cldsa, mtopa, mbota) ! --- outputs else + if (Model%ntal .gt. 0) then + qa(:,:) = tracer1(:,1:lmk,Model%ntal) + else + qa(:,:) = tracer1(:,1:lmk,2) * 0.0 + endif call progcld6 (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly,& ! --- inputs clw, cnvw, cnvc, Grid%xlat, Grid%xlon, & tracer1(:,1:lmk,Model%ntcw), & tracer1(:,1:lmk,Model%ntrw), & tracer1(:,1:lmk,Model%ntiw), & tracer1(:,1:lmk,Model%ntsw), & - tracer1(:,1:lmk,Model%ntgl), & + tracer1(:,1:lmk,Model%ntgl), qa, & Sfcprop%slmsk, Sfcprop%snowd, & tracer1(:,1:lmk,Model%ntclamt),& im, lmk, lmp, clouds, cldsa, mtopa, mbota) ! --- outputs @@ -1630,6 +1636,21 @@ subroutine GFS_radiation_driver & endif ! end_if_ntcw +! --- pass cloud effective radii out, Linjiong Zhou + + if (Model%ncld .eq. 1) then + diag%reff(:,:,1) = clouds(:,:,3) + else if (Model%ncld .eq. 2) then + diag%reff(:,:,1) = clouds(:,:,3) + diag%reff(:,:,2) = clouds(:,:,5) + else if (Model%ncld .eq. 5) then + diag%reff(:,:,1) = clouds(:,:,3) + diag%reff(:,:,2) = clouds(:,:,5) + diag%reff(:,:,3) = clouds(:,:,7) + diag%reff(:,:,4) = clouds(:,:,9) + diag%reff(:,:,5) = clouds(:,:,11) + endif + ! --- ... start radiation calculations ! remember to set heating rate unit to k/sec! !> -# Start SW radiation calculations @@ -1663,16 +1684,20 @@ subroutine GFS_radiation_driver & sfcalb, Radtend%coszen, Model%solcon, & nday, idxday, im, lmk, lmp, Model%lprnt,& htswc, Diag%topfsw, Radtend%sfcfsw, & ! --- outputs - hsw0=htsw0, fdncmp=scmpsw) ! --- optional + hsw0=htsw0, fdncmp=scmpsw, tau067=tau067) ! --- optional else call swrad (plyr, plvl, tlyr, tlvl, qlyr, olyr, & ! --- inputs gasvmr, clouds, Tbd%icsdsw, faersw, & sfcalb, Radtend%coszen, Model%solcon, & nday, idxday, IM, LMK, LMP, Model%lprnt,& htswc, Diag%topfsw, Radtend%sfcfsw, & ! --- outputs - FDNCMP=scmpsw) ! --- optional + FDNCMP=scmpsw, tau067=tau067) ! --- optional endif +! --- pass optical depth out, Linjiong Zhou + + diag%ctau(:,:,1) = tau067 + do k = 1, LM k1 = k + kd Radtend%htrsw(:,k) = htswc(:,k1) @@ -1762,14 +1787,19 @@ subroutine GFS_radiation_driver & clouds, Tbd%icsdlw, faerlw, Radtend%semis, & tsfg, im, lmk, lmp, Model%lprnt, & htlwc, Diag%topflw, Radtend%sfcflw, & ! --- outputs - hlw0=htlw0) ! --- optional + hlw0=htlw0, tau110=tau110) ! --- optional else call lwrad (plyr, plvl, tlyr, tlvl, qlyr, olyr, gasvmr, & ! --- inputs clouds, Tbd%icsdlw, faerlw, Radtend%semis, & tsfg, IM, LMK, LMP, Model%lprnt, & - htlwc, Diag%topflw, Radtend%sfcflw) ! --- outputs + htlwc, Diag%topflw, Radtend%sfcflw, & + tau110=tau110) ! --- outputs endif +! --- pass emissivity out, Linjiong Zhou + + diag%ctau(:,:,2) = tau110 + !> -# Save calculation results !> - Save surface air temp for diurnal adjustment at model t-steps Radtend%tsflw (:) = tsfa(:) diff --git a/GFS_layer/GFS_typedefs.F90 b/GFS_layer/GFS_typedefs.F90 index 1f6c4a57..e6791ce2 100644 --- a/GFS_layer/GFS_typedefs.F90 +++ b/GFS_layer/GFS_typedefs.F90 @@ -6,6 +6,15 @@ module GFS_typedefs use ozne_def, only: levozp, oz_coeff use h2o_def, only: levh2o, h2o_coeff use gfdl_cld_mp_mod, only: rhow +#ifdef USE_COSP + use cosp2_test, only: Ncolumns + use mod_cosp_config, only: Nlvgrid, ntau, npres, nhgt, & + SR_BINS, PARASOL_NREFL, & + cloudsat_DBZE_BINS, & + numMODISReffLiqBins, & + numMODISReffIceBins, & + CFODD_NDBZE, CFODD_NICOD +#endif implicit none !--- version of physics @@ -120,11 +129,19 @@ module GFS_typedefs real (kind=kind_phys), pointer :: exch_h (:,:) => null() !< 3D heat exchange coefficient !--- precipitation + real (kind=kind_phys), pointer :: prew (:) => null() !< water real (kind=kind_phys), pointer :: prer (:) => null() !< rain real (kind=kind_phys), pointer :: prei (:) => null() !< ice real (kind=kind_phys), pointer :: pres (:) => null() !< snow real (kind=kind_phys), pointer :: preg (:) => null() !< graupel + !--- precipitation flux + real (kind=kind_phys), pointer :: prefluxw (:,:) => null() !< water + real (kind=kind_phys), pointer :: prefluxr (:,:) => null() !< rain + real (kind=kind_phys), pointer :: prefluxi (:,:) => null() !< ice + real (kind=kind_phys), pointer :: prefluxs (:,:) => null() !< snow + real (kind=kind_phys), pointer :: prefluxg (:,:) => null() !< graupel + !--- sea surface temperature real (kind=kind_phys), pointer :: sst (:) => null() !< sea surface temperature real (kind=kind_phys), pointer :: ci (:) => null() !< sea ice fraction @@ -489,6 +506,7 @@ module GFS_typedefs !--- radiation control parameters real(kind=kind_phys) :: fhswr !< frequency for shortwave radiation (secs) real(kind=kind_phys) :: fhlwr !< frequency for longwave radiation (secs) + real(kind=kind_phys) :: sollat !< latitude the solar position fixed to (-90. to 90.) integer :: nsswr !< integer trigger for shortwave radiation integer :: nslwr !< integer trigger for longwave radiation integer :: levr !< number of vertical levels for radiation calculations @@ -531,6 +549,7 @@ module GFS_typedefs logical :: swhtr !< flag to output sw heating rate (Radtend%swhc) logical :: fixed_date !< flag to fix astronomy (not solar angle) to initial date logical :: fixed_solhr !< flag to fix solar angle to initial time + logical :: fixed_sollat !< flag to fix solar latitude logical :: daily_mean !< flag to replace cosz with daily mean value !--- microphysical switch @@ -539,6 +558,9 @@ module GFS_typedefs !--- GFDL microphysical parameters logical :: do_inline_mp !< flag for GFDL cloud microphysics + !--- The CFMIP Observation Simulator Package (COSP) + logical :: do_cosp !< flag for COSP + !--- Z-C microphysical parameters logical :: zhao_mic !< flag for Zhao-Carr microphysics real(kind=kind_phys) :: psautco(2) !< [in] auto conversion coeff from ice to snow @@ -565,6 +587,7 @@ module GFS_typedefs logical :: mom4ice !< flag controls mom4 sea ice logical :: use_ufo !< flag for gcycle surface option real(kind=kind_phys) :: czil_sfc !< Zilintkinivich constant + real(kind=kind_phys) :: Ts0 !< constant surface temp. if surface data not found ! -- the Noah MP options @@ -791,6 +814,7 @@ module GFS_typedefs integer :: ntrw !< tracer index for rain water integer :: ntsw !< tracer index for snow water integer :: ntgl !< tracer index for graupel + integer :: ntal !< tracer index for aerosol integer :: ntclamt !< tracer index for cloud amount integer :: ntlnc !< tracer index for liquid number concentration integer :: ntinc !< tracer index for ice number concentration @@ -995,6 +1019,92 @@ module GFS_typedefs procedure :: create => radtend_create !< allocate array data end type GFS_radtend_type +#ifdef USE_COSP +!---------------------------------------------------------------- +! cosp_type, Linjiong Zhou +!---------------------------------------------------------------- + type cosp_type + real (kind=kind_phys), pointer :: cltisccp (:) => null() + real (kind=kind_phys), pointer :: meantbisccp (:) => null() + real (kind=kind_phys), pointer :: meantbclrisccp (:) => null() + real (kind=kind_phys), pointer :: pctisccp (:) => null() + real (kind=kind_phys), pointer :: tauisccp (:) => null() + real (kind=kind_phys), pointer :: albisccp (:) => null() + real (kind=kind_phys), pointer :: misr_meanztop (:) => null() + real (kind=kind_phys), pointer :: misr_cldarea (:) => null() + real (kind=kind_phys), pointer :: cltmodis (:) => null() + real (kind=kind_phys), pointer :: clwmodis (:) => null() + real (kind=kind_phys), pointer :: climodis (:) => null() + real (kind=kind_phys), pointer :: clhmodis (:) => null() + real (kind=kind_phys), pointer :: clmmodis (:) => null() + real (kind=kind_phys), pointer :: cllmodis (:) => null() + real (kind=kind_phys), pointer :: tautmodis (:) => null() + real (kind=kind_phys), pointer :: tauwmodis (:) => null() + real (kind=kind_phys), pointer :: tauimodis (:) => null() + real (kind=kind_phys), pointer :: tautlogmodis (:) => null() + real (kind=kind_phys), pointer :: tauwlogmodis (:) => null() + real (kind=kind_phys), pointer :: tauilogmodis (:) => null() + real (kind=kind_phys), pointer :: reffclwmodis (:) => null() + real (kind=kind_phys), pointer :: reffclimodis (:) => null() + real (kind=kind_phys), pointer :: pctmodis (:) => null() + real (kind=kind_phys), pointer :: lwpmodis (:) => null() + real (kind=kind_phys), pointer :: iwpmodis (:) => null() + real (kind=kind_phys), pointer :: cltlidarradar (:) => null() + real (kind=kind_phys), pointer :: cllcalipsoice (:) => null() + real (kind=kind_phys), pointer :: clmcalipsoice (:) => null() + real (kind=kind_phys), pointer :: clhcalipsoice (:) => null() + real (kind=kind_phys), pointer :: cltcalipsoice (:) => null() + real (kind=kind_phys), pointer :: cllcalipsoliq (:) => null() + real (kind=kind_phys), pointer :: clmcalipsoliq (:) => null() + real (kind=kind_phys), pointer :: clhcalipsoliq (:) => null() + real (kind=kind_phys), pointer :: cltcalipsoliq (:) => null() + real (kind=kind_phys), pointer :: cllcalipsoun (:) => null() + real (kind=kind_phys), pointer :: clmcalipsoun (:) => null() + real (kind=kind_phys), pointer :: clhcalipsoun (:) => null() + real (kind=kind_phys), pointer :: cltcalipsoun (:) => null() + real (kind=kind_phys), pointer :: cllcalipso (:) => null() + real (kind=kind_phys), pointer :: clmcalipso (:) => null() + real (kind=kind_phys), pointer :: clhcalipso (:) => null() + real (kind=kind_phys), pointer :: cltcalipso (:) => null() + real (kind=kind_phys), pointer :: clopaquecalipso (:) => null() + real (kind=kind_phys), pointer :: clthincalipso (:) => null() + real (kind=kind_phys), pointer :: clzopaquecalipso (:) => null() + real (kind=kind_phys), pointer :: clopaquetemp (:) => null() + real (kind=kind_phys), pointer :: clthintemp (:) => null() + real (kind=kind_phys), pointer :: clzopaquetemp (:) => null() + real (kind=kind_phys), pointer :: clopaquemeanz (:) => null() + real (kind=kind_phys), pointer :: clthinmeanz (:) => null() + real (kind=kind_phys), pointer :: clthinemis (:) => null() + real (kind=kind_phys), pointer :: clopaquemeanzse (:) => null() + real (kind=kind_phys), pointer :: clthinmeanzse (:) => null() + real (kind=kind_phys), pointer :: clzopaquecalipsose (:) => null() + real (kind=kind_phys), pointer :: cllgrLidar532 (:) => null() + real (kind=kind_phys), pointer :: clmgrLidar532 (:) => null() + real (kind=kind_phys), pointer :: clhgrLidar532 (:) => null() + real (kind=kind_phys), pointer :: cltgrLidar532 (:) => null() + real (kind=kind_phys), pointer :: cllatlid (:) => null() + real (kind=kind_phys), pointer :: clmatlid (:) => null() + real (kind=kind_phys), pointer :: clhatlid (:) => null() + real (kind=kind_phys), pointer :: cltatlid (:) => null() + real (kind=kind_phys), pointer :: ptcloudsatflag0 (:) => null() + real (kind=kind_phys), pointer :: ptcloudsatflag1 (:) => null() + real (kind=kind_phys), pointer :: ptcloudsatflag2 (:) => null() + real (kind=kind_phys), pointer :: ptcloudsatflag3 (:) => null() + real (kind=kind_phys), pointer :: ptcloudsatflag4 (:) => null() + real (kind=kind_phys), pointer :: ptcloudsatflag5 (:) => null() + real (kind=kind_phys), pointer :: ptcloudsatflag6 (:) => null() + real (kind=kind_phys), pointer :: ptcloudsatflag7 (:) => null() + real (kind=kind_phys), pointer :: ptcloudsatflag8 (:) => null() + real (kind=kind_phys), pointer :: ptcloudsatflag9 (:) => null() + real (kind=kind_phys), pointer :: cloudsatpia (:) => null() + real (kind=kind_phys), pointer :: cloudsat_tcc (:) => null() + real (kind=kind_phys), pointer :: cloudsat_tcc2 (:) => null() + real (kind=kind_phys), pointer :: npdfcld (:) => null() + real (kind=kind_phys), pointer :: npdfdrz (:) => null() + real (kind=kind_phys), pointer :: npdfrain (:) => null() + end type cosp_type +#endif + !---------------------------------------------------------------- ! GFS_diag_type ! internal diagnostic type used as arguments to gbphys and grrad @@ -1006,6 +1116,8 @@ module GFS_typedefs !< hardcoded field indices, opt. includes aerosols! real (kind=kind_phys), pointer :: cloud (:,:,:) => null() !< to save time accumulated 3-d fields defined as:! !< hardcoded field indices + real (kind=kind_phys), pointer :: reff(:,:,:) => null() !< to save cloud effective radii + real (kind=kind_phys), pointer :: ctau(:,:,:) => null() !< to save cloud optical depth and emissivity type (topfsw_type), pointer :: topfsw(:) => null() !< sw radiation fluxes at toa, components: ! %upfxc - total sky upward sw flux at toa (w/m**2) ! %dnfxc - total sky downward sw flux at toa (w/m**2) @@ -1013,6 +1125,9 @@ module GFS_typedefs type (topflw_type), pointer :: topflw(:) => null() !< lw radiation fluxes at top, component: ! %upfxc - total sky upward lw flux at toa (w/m**2) ! %upfx0 - clear sky upward lw flux at toa (w/m**2) +#ifdef USE_COSP + type (cosp_type) :: cosp !< cosp output +#endif ! Input/output - used by physics real (kind=kind_phys), pointer :: srunoff(:) => null() !< surface water runoff (from lsm) @@ -1212,16 +1327,30 @@ subroutine statein_create (Statein, IM, Model) endif + allocate (Statein%prew(IM)) allocate (Statein%prer(IM)) allocate (Statein%prei(IM)) allocate (Statein%pres(IM)) allocate (Statein%preg(IM)) + Statein%prew = clear_val Statein%prer = clear_val Statein%prei = clear_val Statein%pres = clear_val Statein%preg = clear_val + allocate (Statein%prefluxw(IM,Model%levs)) + allocate (Statein%prefluxr(IM,Model%levs)) + allocate (Statein%prefluxi(IM,Model%levs)) + allocate (Statein%prefluxs(IM,Model%levs)) + allocate (Statein%prefluxg(IM,Model%levs)) + + Statein%prefluxw = clear_val + Statein%prefluxr = clear_val + Statein%prefluxi = clear_val + Statein%prefluxs = clear_val + Statein%prefluxg = clear_val + allocate (Statein%sst(IM)) allocate (Statein%ci(IM)) @@ -1882,6 +2011,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- radiation parameters real(kind=kind_phys) :: fhswr = 3600. !< frequency for shortwave radiation (secs) real(kind=kind_phys) :: fhlwr = 3600. !< frequency for longwave radiation (secs) + real(kind=kind_phys) :: sollat = 0. !< latitude the solar position fixed to (-90. to 90.) integer :: levr = -99 !< number of vertical levels for radiation calculations integer :: nfxr = 39 !< second dimension of input/output array fluxr integer :: nkld = 8 !< second dimension of input/output array fluxr @@ -1919,11 +2049,15 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: swhtr = .true. !< flag to output sw heating rate (Radtend%swhc) logical :: fixed_date = .false. !< flag to fix astronomy (not solar angle) to initial date logical :: fixed_solhr = .false. !< flag to fix solar angle to initial time + logical :: fixed_sollat = .false. !< flag to fix solar latitude logical :: daily_mean = .false. !< flag to replace cosz with daily mean value !--- GFDL microphysical parameters logical :: do_inline_mp = .false. !< flag for GFDL cloud microphysics + !--- The CFMIP Observation Simulator Package (COSP) + logical :: do_cosp = .false. !< flag for COSP + !--- Z-C microphysical parameters integer :: ncld = 1 !< cnoice of cloud scheme logical :: zhao_mic = .false. !< flag for Zhao-Carr microphysics @@ -1949,6 +2083,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: mom4ice = .false. !< flag controls mom4 sea ice logical :: use_ufo = .false. !< flag for gcycle surface option real(kind=kind_phys) :: czil_sfc = 0.8 !< Zilintkivitch constant + real(kind=kind_phys) :: Ts0 = 300. !< constant surface temp. if surface data not found ! -- to use Noah MP, lsm needs to be set to 2 and both ivegsrc and isot are set ! to 1 - MODIS IGBP and STATSGO - the defaults are the same as in the @@ -2198,12 +2333,12 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & fhswr, fhlwr, levr, nfxr, aero_in, iflip, isol, ico2, ialb, & isot, iems, iaer, iovr_sw, iovr_lw, ictm, isubc_sw, & isubc_lw, crick_proof, ccnorm, lwhtr, swhtr, nkld, & - fixed_date, fixed_solhr, daily_mean, & + fixed_date, fixed_solhr, fixed_sollat, daily_mean, sollat, & !--- microphysical parameterizations ncld, do_inline_mp, zhao_mic, psautco, prautco, evpco, & - wminco, fprcp, mg_dcs, mg_qcvar, mg_ts_auto_ice, & + do_cosp, wminco, fprcp, mg_dcs, mg_qcvar, mg_ts_auto_ice, & !--- land/surface model control - lsm, lsoil, nmtvr, ivegsrc, mom4ice, use_ufo, czil_sfc, & + lsm, lsoil, nmtvr, ivegsrc, mom4ice, use_ufo, czil_sfc, Ts0, & ! Noah MP options iopt_dveg,iopt_crs,iopt_btr,iopt_run,iopt_sfc, iopt_frz, & iopt_inf, iopt_rad,iopt_alb,iopt_snf,iopt_tbot,iopt_stc, & @@ -2341,6 +2476,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- radiation control parameters Model%fhswr = fhswr Model%fhlwr = fhlwr + Model%sollat = sollat Model%nsswr = nint(fhswr/Model%dtp) Model%nslwr = nint(fhlwr/Model%dtp) if (levr < 0) then @@ -2368,12 +2504,15 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%swhtr = swhtr Model%fixed_date = fixed_date Model%fixed_solhr = fixed_solhr + Model%fixed_sollat = fixed_sollat Model%daily_mean = daily_mean !--- microphysical switch Model%ncld = ncld !--- GFDL microphysical parameters Model%do_inline_mp = do_inline_mp + !--- The CFMIP Observation Simulator Package (COSP) + Model%do_cosp = do_cosp !--- Zhao-Carr MP parameters Model%zhao_mic = zhao_mic Model%psautco = psautco @@ -2394,6 +2533,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%mom4ice = mom4ice Model%use_ufo = use_ufo Model%czil_sfc = czil_sfc + Model%Ts0 = Ts0 ! Noah MP options from namelist ! @@ -2592,6 +2732,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%ntrw = get_tracer_index(Model%tracer_names, 'rainwat', Model%me, Model%master, Model%debug) Model%ntsw = get_tracer_index(Model%tracer_names, 'snowwat', Model%me, Model%master, Model%debug) Model%ntgl = get_tracer_index(Model%tracer_names, 'graupel', Model%me, Model%master, Model%debug) + Model%ntal = get_tracer_index(Model%tracer_names, 'aerosol', Model%me, Model%master, Model%debug) Model%ntclamt = get_tracer_index(Model%tracer_names, 'cld_amt', Model%me, Model%master, Model%debug) Model%ntlnc = get_tracer_index(Model%tracer_names, 'water_nc', Model%me, Model%master, Model%debug) Model%ntinc = get_tracer_index(Model%tracer_names, 'ice_nc', Model%me, Model%master, Model%debug) @@ -2805,6 +2946,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & print *,' scale & aerosol-aware mass-flux deep conv scheme' endif else + Model%imfdeepcnv = -1 print*, ' Deep convection scheme disabled' endif endif @@ -3006,6 +3148,7 @@ subroutine control_print(Model) print *, 'radiation control parameters' print *, ' fhswr : ', Model%fhswr print *, ' fhlwr : ', Model%fhlwr + print *, ' sollat : ', Model%sollat print *, ' nsswr : ', Model%nsswr print *, ' nslwr : ', Model%nslwr print *, ' levr : ', Model%levr @@ -3033,12 +3176,15 @@ subroutine control_print(Model) print *, ' swhtr : ', Model%swhtr print *, ' fixed_date : ', Model%fixed_date print *, ' fixed_solhr : ', Model%fixed_solhr + print *, ' fixed_sollat : ', Model%fixed_sollat print *, ' daily_mean : ', Model%daily_mean print *, ' ' print *, 'microphysical switch' print *, ' ncld : ', Model%ncld print *, ' GFDL microphysical parameters' print *, ' do_inline_mp : ', Model%do_inline_mp + print *, ' The CFMIP Observation Simulator Package (COSP)' + print *, ' do_cosp : ', Model%do_cosp print *, ' Z-C microphysical parameters' print *, ' zhao_mic : ', Model%zhao_mic print *, ' psautco : ', Model%psautco @@ -3059,6 +3205,7 @@ subroutine control_print(Model) print *, ' mom4ice : ', Model%mom4ice print *, ' use_ufo : ', Model%use_ufo print *, ' czil_sfc : ', Model%czil_sfc + print *, ' Ts0 : ', Model%Ts0 if (Model%lsm == Model%lsm_noahmp) then print *, ' Noah MP LSM is used, the options are' @@ -3229,6 +3376,7 @@ subroutine control_print(Model) print *, ' ntrw : ', Model%ntrw print *, ' ntsw : ', Model%ntsw print *, ' ntgl : ', Model%ntgl + print *, ' ntal : ', Model%ntal print *, ' ntclamt : ', Model%ntclamt print *, ' ntlnc : ', Model%ntlnc print *, ' ntinc : ', Model%ntinc @@ -3474,6 +3622,8 @@ subroutine diag_create (Diag, IM, Model) !--- Radiation allocate (Diag%fluxr (IM,Model%nfxr)) allocate (Diag%cloud (IM,Model%levs,Model%nkld)) + allocate (Diag%reff (IM,Model%levs,Model%ncld)) + allocate (Diag%ctau (IM,Model%levs,2)) allocate (Diag%topfsw (IM)) allocate (Diag%topflw (IM)) !--- Physics @@ -3586,6 +3736,88 @@ subroutine diag_create (Diag, IM, Model) allocate (Diag%det_mf (IM,Model%levs)) allocate (Diag%cldcov (IM,Model%levs)) endif +#ifdef USE_COSP + if (Model%do_cosp) then + allocate (Diag%cosp%cltisccp (IM)) + allocate (Diag%cosp%meantbisccp (IM)) + allocate (Diag%cosp%meantbclrisccp (IM)) + allocate (Diag%cosp%pctisccp (IM)) + allocate (Diag%cosp%tauisccp (IM)) + allocate (Diag%cosp%albisccp (IM)) + allocate (Diag%cosp%misr_meanztop (IM)) + allocate (Diag%cosp%misr_cldarea (IM)) + allocate (Diag%cosp%cltmodis (IM)) + allocate (Diag%cosp%clwmodis (IM)) + allocate (Diag%cosp%climodis (IM)) + allocate (Diag%cosp%clhmodis (IM)) + allocate (Diag%cosp%clmmodis (IM)) + allocate (Diag%cosp%cllmodis (IM)) + allocate (Diag%cosp%tautmodis (IM)) + allocate (Diag%cosp%tauwmodis (IM)) + allocate (Diag%cosp%tauimodis (IM)) + allocate (Diag%cosp%tautlogmodis (IM)) + allocate (Diag%cosp%tauwlogmodis (IM)) + allocate (Diag%cosp%tauilogmodis (IM)) + allocate (Diag%cosp%reffclwmodis (IM)) + allocate (Diag%cosp%reffclimodis (IM)) + allocate (Diag%cosp%pctmodis (IM)) + allocate (Diag%cosp%lwpmodis (IM)) + allocate (Diag%cosp%iwpmodis (IM)) + allocate (Diag%cosp%cltlidarradar (IM)) + allocate (Diag%cosp%cllcalipsoice (IM)) + allocate (Diag%cosp%clmcalipsoice (IM)) + allocate (Diag%cosp%clhcalipsoice (IM)) + allocate (Diag%cosp%cltcalipsoice (IM)) + allocate (Diag%cosp%cllcalipsoliq (IM)) + allocate (Diag%cosp%clmcalipsoliq (IM)) + allocate (Diag%cosp%clhcalipsoliq (IM)) + allocate (Diag%cosp%cltcalipsoliq (IM)) + allocate (Diag%cosp%cllcalipsoun (IM)) + allocate (Diag%cosp%clmcalipsoun (IM)) + allocate (Diag%cosp%clhcalipsoun (IM)) + allocate (Diag%cosp%cltcalipsoun (IM)) + allocate (Diag%cosp%cllcalipso (IM)) + allocate (Diag%cosp%clmcalipso (IM)) + allocate (Diag%cosp%clhcalipso (IM)) + allocate (Diag%cosp%cltcalipso (IM)) + allocate (Diag%cosp%clopaquecalipso (IM)) + allocate (Diag%cosp%clthincalipso (IM)) + allocate (Diag%cosp%clzopaquecalipso (IM)) + allocate (Diag%cosp%clopaquetemp (IM)) + allocate (Diag%cosp%clthintemp (IM)) + allocate (Diag%cosp%clzopaquetemp (IM)) + allocate (Diag%cosp%clopaquemeanz (IM)) + allocate (Diag%cosp%clthinmeanz (IM)) + allocate (Diag%cosp%clthinemis (IM)) + allocate (Diag%cosp%clopaquemeanzse (IM)) + allocate (Diag%cosp%clthinmeanzse (IM)) + allocate (Diag%cosp%clzopaquecalipsose (IM)) + allocate (Diag%cosp%cllgrLidar532 (IM)) + allocate (Diag%cosp%clmgrLidar532 (IM)) + allocate (Diag%cosp%clhgrLidar532 (IM)) + allocate (Diag%cosp%cltgrLidar532 (IM)) + allocate (Diag%cosp%cllatlid (IM)) + allocate (Diag%cosp%clmatlid (IM)) + allocate (Diag%cosp%clhatlid (IM)) + allocate (Diag%cosp%cltatlid (IM)) + allocate (Diag%cosp%ptcloudsatflag0 (IM)) + allocate (Diag%cosp%ptcloudsatflag1 (IM)) + allocate (Diag%cosp%ptcloudsatflag2 (IM)) + allocate (Diag%cosp%ptcloudsatflag3 (IM)) + allocate (Diag%cosp%ptcloudsatflag4 (IM)) + allocate (Diag%cosp%ptcloudsatflag5 (IM)) + allocate (Diag%cosp%ptcloudsatflag6 (IM)) + allocate (Diag%cosp%ptcloudsatflag7 (IM)) + allocate (Diag%cosp%ptcloudsatflag8 (IM)) + allocate (Diag%cosp%ptcloudsatflag9 (IM)) + allocate (Diag%cosp%cloudsatpia (IM)) + allocate (Diag%cosp%cloudsat_tcc (IM)) + allocate (Diag%cosp%cloudsat_tcc2 (IM)) + allocate (Diag%cosp%npdfcld (IM)) + allocate (Diag%cosp%npdfdrz (IM)) + allocate (Diag%cosp%npdfrain (IM)) + endif +#endif allocate (Diag%ps_dt(IM)) @@ -3603,6 +3835,8 @@ subroutine diag_rad_zero(Diag, Model) Diag%fluxr = zero Diag%cloud = zero + Diag%reff = zero + Diag%ctau = zero Diag%topfsw%upfxc = zero Diag%topfsw%dnfxc = zero Diag%topfsw%upfx0 = zero @@ -3735,7 +3969,7 @@ subroutine diag_phys_zero (Diag, Model, linit, iauwindow_center) if (present(linit) ) set_totprcp = linit if (present(iauwindow_center) ) set_totprcp = iauwindow_center if (set_totprcp) then - if (Model%me == 0) print *,'set_totprcp T kdt=', Model%kdt + !if (Model%me == 0) print *,'set_totprcp T kdt=', Model%kdt Diag%totprcp = zero Diag%cnvprcp = zero Diag%totice = zero diff --git a/IPD_layer/IPD_driver.F90 b/IPD_layer/IPD_driver.F90 index a0e4c0be..6241422e 100644 --- a/IPD_layer/IPD_driver.F90 +++ b/IPD_layer/IPD_driver.F90 @@ -6,7 +6,7 @@ module IPD_driver use physics_abstraction_layer, only: initialize, time_vary_step, & radiation_step1, physics_step1, & - physics_step2 + physics_step2, physics_end use physics_diag_layer, only: diag_populate @@ -32,6 +32,7 @@ module IPD_driver public IPD_radiation_step public IPD_physics_step1 public IPD_physics_step2 + public IPD_physics_end CONTAINS !******************************************************************************************* @@ -138,4 +139,18 @@ subroutine IPD_physics_step2 (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart) end subroutine IPD_physics_step2 + +!------------------- +! IPD physics end +!------------------- + subroutine IPD_physics_end (IPD_Control) + + implicit none + + type(IPD_control_type), intent(inout) :: IPD_Control + + call physics_end (IPD_Control) + + end subroutine IPD_physics_end + end module IPD_driver diff --git a/README.md b/README.md index eba9e5eb..641544c5 100644 --- a/README.md +++ b/README.md @@ -1,5 +1,7 @@ # SHiELD_physics +The source contained herein reflects the 202210 release of the SHiELD_physics from GFDL. + SHiELD_physics contains the infrastructure and physical parameterizations used within the SHiELD atmosphere model. More information is available on the [GFDL SHiELD page](https://www.gfdl.noaa.gov/shield/). diff --git a/RELEASE.md b/RELEASE.md new file mode 100644 index 00000000..fbecb743 --- /dev/null +++ b/RELEASE.md @@ -0,0 +1,18 @@ +# RELEASE NOTES for FV3 202210: Summary +FV3-202210-public --- October 2022 +Lucas Harris, GFDL lucas.harris@noaa.gov + +This version has been tested with the FV3 Dynamical Core release 202210 +and with FMS release 2022.03 from https://github.com/NOAA-GFDL/FMS + +This release includes the following: +- Release of the GFDL Microphysics Version 3 +- Fix for first_time_step bug +- Fix for bug in which global physics diagnostic messages were printed out every timestep. +- Fix specification of time-averaged flux variable +- Fix segmentation fault when writing coarse-grained surface restart files +- COSP Implementation +- NOAH MP update +- Introduce namelist parameter, Ts0, that is used to specify the surface temperature +- Added option to fix solar declination for doubly periodic experiments +- Diagnostic totprcp_ave has been renamed to totprcpb_ave diff --git a/atmos_drivers/coupled/atmos_model.F90 b/atmos_drivers/coupled/atmos_model.F90 index 80fcf650..527711d2 100644 --- a/atmos_drivers/coupled/atmos_model.F90 +++ b/atmos_drivers/coupled/atmos_model.F90 @@ -88,8 +88,8 @@ module atmos_model_mod use IPD_driver, only: IPD_initialize, IPD_setup_step, & IPD_radiation_step, & IPD_physics_step1, & - IPD_physics_step2 -#ifdef STOCHY + IPD_physics_step2, IPD_physics_end +#ifdef STOCHY use stochastic_physics, only: init_stochastic_physics, & run_stochastic_physics use stochastic_physics_sfc, only: run_stochastic_physics_sfc @@ -158,7 +158,7 @@ module atmos_model_mod logical :: dycore_only = .false. logical :: debug = .false. logical :: sync = .false. -logical :: first_time_step = .true. +logical :: first_time_step = .false. logical :: fprint = .true. logical :: enforce_rst_cksum = .true. ! enforce or override data integrity restart checksums real, dimension(4096) :: fdiag = 0. ! xic: TODO: this is hard coded, space can run out in some cases. Should make it allocatable. @@ -667,7 +667,7 @@ subroutine update_atmos_model_state (Atmos) if (mpp_pe() == mpp_root_pe()) write(6,*) ' gfs diags time since last bucket empty: ',time_int/3600.,'hrs' call atmosphere_nggps_diag(Atmos%Time) endif - if (ANY(nint(fdiag(:)*3600.0) == seconds) .or. (fdiag_fix .and. mod(seconds, nint(fdiag(1)*3600.0)) .eq. 0) .or. first_time_step) then + if (ANY(nint(fdiag(:)*3600.0) == seconds) .or. (fdiag_fix .and. mod(seconds, nint(fdiag(1)*3600.0)) .eq. 0) .or. (IPD_Control%kdt == 1 .and. first_time_step)) then if(Atmos%iau_offset > zero) then if( time_int - Atmos%iau_offset*3600. > zero ) then time_int = time_int - Atmos%iau_offset*3600. @@ -725,6 +725,8 @@ subroutine atmos_model_end (Atmos) !---local variables integer :: idx + call IPD_physics_end (IPD_Control) + !----------------------------------------------------------------------- !---- termination routine for atmospheric model ---- diff --git a/gsmphys/gfdl_cld_mp.F90 b/gsmphys/gfdl_cld_mp.F90 new file mode 100644 index 00000000..1cace82a --- /dev/null +++ b/gsmphys/gfdl_cld_mp.F90 @@ -0,0 +1,7614 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the FV3 dynamical core. +!* +!* The FV3 dynamical core is free software: you can redistribute it +!* and/or modify it under the terms of the +!* GNU Lesser General Public License as published by the +!* Free Software Foundation, either version 3 of the License, or +!* (at your option) any later version. +!* +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* See the GNU General Public License for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with the FV3 dynamical core. +!* If not, see . +!*********************************************************************** + +! ======================================================================= +! GFDL Cloud Microphysics Package (GFDL MP) Version 3 +! The algorithms are originally derived from Lin et al. (1983). +! Most of the key elements have been simplified / improved. +! This code at this stage bears little to no similarity to the original Lin MP in ZETAC. +! Developers: Linjiong Zhou and the GFDL FV3 Team +! References: +! Version 0: Chen and Lin (2011 doi: 10.1029/2011GL047629, 2013 doi: 10.1175/JCLI-D-12-00061.1) +! Version 1: Zhou et al. (2019 doi: 10.1175/BAMS-D-17-0246.1) +! Version 2: Harris et al. (2020 doi: 10.1029/2020MS002223), Zhou et al. (2022 doi: 10.25923/pz3c-8b96) +! Version 3: Zhou et al. (2022 doi: 10.1029/2021MS002971) +! ======================================================================= + +module gfdl_cld_mp_mod + + implicit none + + private + + ! ----------------------------------------------------------------------- + ! interface functions + ! ----------------------------------------------------------------------- + + interface wqs + procedure wes_t + procedure wqs_trho + procedure wqs_ptqv + end interface wqs + + interface mqs + procedure mes_t + procedure mqs_trho + procedure mqs_ptqv + end interface mqs + + interface iqs + procedure ies_t + procedure iqs_trho + procedure iqs_ptqv + end interface iqs + + interface mhc + procedure mhc3 + procedure mhc4 + procedure mhc6 + end interface mhc + + interface wet_bulb + procedure wet_bulb_dry + procedure wet_bulb_moist + end interface wet_bulb + + ! ----------------------------------------------------------------------- + ! public subroutines, functions, and variables + ! ----------------------------------------------------------------------- + + public :: gfdl_cld_mp_init + public :: gfdl_cld_mp_driver + public :: gfdl_cld_mp_end + public :: fast_sat_adj, cld_eff_rad, rad_ref + public :: qs_init, wqs, mqs, mqs3d + public :: c_liq, c_ice, rhow, wet_bulb + public :: cv_air, cv_vap, mtetw + public :: hlv, hlf, tice + + ! ----------------------------------------------------------------------- + ! precision definition + ! ----------------------------------------------------------------------- + + integer, parameter :: r8 = 8 ! double precision + + ! ----------------------------------------------------------------------- + ! initialization conditions + ! ----------------------------------------------------------------------- + + logical :: tables_are_initialized = .false. ! initialize satuation tables + + ! ----------------------------------------------------------------------- + ! physics constants + ! ----------------------------------------------------------------------- + + real, parameter :: grav = 9.80665 ! acceleration due to gravity (m/s^2), ref: IFS + + real, parameter :: rgrav = 1.0 / grav ! inversion of gravity acceleration (s^2/m) + + real, parameter :: pi = 4.0 * atan (1.0) ! ratio of circle circumference to diameter + + real, parameter :: boltzmann = 1.38064852e-23 ! boltzmann constant (J/K) + real, parameter :: avogadro = 6.02214076e23 ! avogadro number (1/mol) + real, parameter :: runiver = avogadro * boltzmann ! 8.314459727525675, universal gas constant (J/K/mol) + real, parameter :: mmd = 2.89644e-2 ! dry air molar mass (kg/mol), ref: IFS + real, parameter :: mmv = 1.80153e-2 ! water vapor molar mass (kg/mol), ref: IFS + + real, parameter :: rdgas = 287.05 ! gas constant for dry air (J/kg/K): ref: GFDL, GFS + real, parameter :: rvgas = 461.50 ! gas constant for water vapor (J/kg/K): ref: GFDL, GFS + !real, parameter :: rdgas = runiver / mmd ! 287.0578961596192, gas constant for dry air (J/kg/K) + !real, parameter :: rvgas = runiver / mmv ! 461.52213549181386, gas constant for water vapor (J/kg/K) + + real, parameter :: zvir = rvgas / rdgas - 1. ! 0.6077667316114637 + real, parameter :: eps = rdgas / rvgas ! 0.6219934994582882 + real, parameter :: epsm1 = rdgas / rvgas - 1. ! -0.3780065005417118 + + real, parameter :: tice = 273.15 ! freezing temperature (K): ref: GFDL, GFS + !real, parameter :: tice = 273.16 ! freezing temperature (K), ref: IFS + + real, parameter :: cp_air = 1004.6 ! heat capacity of dry air at constant pressure (J/kg/K): ref: GFDL, GFS + real, parameter :: cv_air = cp_air - rdgas ! 717.55, heat capacity of dry air at constant volume (J/kg/K): ref: GFDL, GFS + !real, parameter :: cp_air = 7. / 2. * rdgas ! 1004.7026365586671, heat capacity of dry air at constant pressure (J/kg/K) + !real, parameter :: cv_air = 5. / 2. * rdgas ! 717.644740399048, heat capacity of dry air at constant volume (J/kg/K) + real, parameter :: cp_vap = 4.0 * rvgas ! 1846.0885419672554, heat capacity of water vapor at constnat pressure (J/kg/K) + real, parameter :: cv_vap = 3.0 * rvgas ! 1384.5664064754415, heat capacity of water vapor at constant volume (J/kg/K) + + real, parameter :: c_ice = 2.106e3 ! heat capacity of ice at 0 deg C (J/kg/K), ref: IFS + real, parameter :: c_liq = 4.218e3 ! heat capacity of water at 0 deg C (J/kg/K), ref: IFS + + real, parameter :: dc_vap = cp_vap - c_liq ! - 2371.9114580327446, isobaric heating / cooling (J/kg/K) + real, parameter :: dc_ice = c_liq - c_ice ! 2112.0, isobaric heating / colling (J/kg/K) + real, parameter :: d2_ice = cp_vap - c_ice ! - 259.9114580327446, isobaric heating / cooling (J/kg/K) + + real, parameter :: hlv = 2.5e6 ! latent heat of evaporation at 0 deg C (J/kg): ref: GFDL, GFS + real, parameter :: hlf = 3.3358e5 ! latent heat of fusion at 0 deg C (J/kg): ref: GFDL, GFS + !real, parameter :: hlv = 2.5008e6 ! latent heat of evaporation at 0 deg C (J/kg), ref: IFS + !real, parameter :: hlf = 3.345e5 ! latent heat of fusion at 0 deg C (J/kg), ref: IFS + + real, parameter :: visd = 1.717e-5 ! dynamics viscosity of air at 0 deg C and 1000 hPa (Mason, 1971) (kg/m/s) + real, parameter :: visk = 1.35e-5 ! kinematic viscosity of air at 0 deg C and 1000 hPa (Mason, 1971) (m^2/s) + real, parameter :: vdifu = 2.25e-5 ! diffusivity of water vapor in air at 0 deg C and 1000 hPa (Mason, 1971) (m^2/s) + real, parameter :: tcond = 2.40e-2 ! thermal conductivity of air at 0 deg C and 1000 hPa (Mason, 1971) (J/m/s/K) + + real, parameter :: rho0 = 1.0 ! reference air density (kg/m^3), ref: IFS + real, parameter :: cdg = 3.15121 ! drag coefficient of graupel (Locatelli and Hobbs, 1974) + real, parameter :: cdh = 0.5 ! drag coefficient of hail (Heymsfield and Wright, 2014) + + real (kind = r8), parameter :: lv0 = hlv - dc_vap * tice ! 3148711.3338762247, evaporation latent heat coeff. at 0 deg K (J/kg) + real (kind = r8), parameter :: li0 = hlf - dc_ice * tice ! - 242413.92000000004, fussion latent heat coeff. at 0 deg K (J/kg) + real (kind = r8), parameter :: li2 = lv0 + li0 ! 2906297.413876225, sublimation latent heat coeff. at 0 deg K (J/kg) + + real (kind = r8), parameter :: e00 = 611.21 ! saturation vapor pressure at 0 deg C (Pa), ref: IFS + + ! ----------------------------------------------------------------------- + ! predefined parameters + ! ----------------------------------------------------------------------- + + integer, parameter :: length = 2621 ! length of the saturation table + + real, parameter :: qcmin = 1.0e-15 ! min value for cloud condensates (kg/kg) + real, parameter :: qfmin = 1.0e-8 ! min value for sedimentation (kg/kg) + + real, parameter :: dz_min = 1.0e-2 ! used for correcting flipped height (m) + + real, parameter :: rhow = 1.0e3 ! density of cloud water (kg/m^3) + real, parameter :: rhoi = 9.17e2 ! density of cloud ice (kg/m^3) + real, parameter :: rhor = 1.0e3 ! density of rain (Lin et al. 1983) (kg/m^3) + real, parameter :: rhos = 1.0e2 ! density of snow (Lin et al. 1983) (kg/m^3) + real, parameter :: rhog = 4.0e2 ! density of graupel (Rutledge and Hobbs 1984) (kg/m^3) + real, parameter :: rhoh = 9.17e2 ! density of hail (Lin et al. 1983) (kg/m^3) + + real, parameter :: dt_fr = 8.0 ! t_wfr - dt_fr: minimum temperature water can exist (Moore and Molinero 2011) + + real (kind = r8), parameter :: one_r8 = 1.0 ! constant 1 + + ! ----------------------------------------------------------------------- + ! namelist parameters + ! ----------------------------------------------------------------------- + + integer :: ntimes = 1 ! cloud microphysics sub cycles + + integer :: cfflag = 1 ! cloud fraction scheme + ! 1: GFDL cloud scheme + ! 2: Xu and Randall (1996) + ! 3: Park et al. (2016) + ! 4: Gultepe and Isaac (2007) + + integer :: icloud_f = 0 ! GFDL cloud scheme + ! 0: subgrid variability based scheme + ! 1: same as 0, but for old fvgfs implementation + ! 2: binary cloud scheme + ! 3: extension of 0 + + integer :: irain_f = 0 ! cloud water to rain auto conversion scheme + ! 0: subgrid variability based scheme + ! 1: no subgrid varaibility + + integer :: inflag = 1 ! ice nucleation scheme + ! 1: Hong et al. (2004) + ! 2: Meyers et al. (1992) + ! 3: Meyers et al. (1992) + ! 4: Cooper (1986) + ! 5: Fletcher (1962) + + integer :: igflag = 3 ! ice generation scheme + ! 1: WSM6 + ! 2: WSM6 with 0 at 0 C + ! 3: WSM6 with 0 at 0 C and fixed value at - 10 C + ! 4: combination of 1 and 3 + + integer :: ifflag = 1 ! ice fall scheme + ! 1: Deng and Mace (2008) + ! 2: Heymsfield and Donner (1990) + + integer :: rewflag = 1 ! cloud water effective radius scheme + ! 1: Martin et al. (1994) + ! 2: Martin et al. (1994), GFDL revision + ! 3: Kiehl et al. (1994) + ! 4: effective radius + + integer :: reiflag = 5 ! cloud ice effective radius scheme + ! 1: Heymsfield and Mcfarquhar (1996) + ! 2: Donner et al. (1997) + ! 3: Fu (2007) + ! 4: Kristjansson et al. (2000) + ! 5: Wyser (1998) + ! 6: Sun and Rikus (1999), Sun (2001) + ! 7: effective radius + + integer :: rerflag = 1 ! rain effective radius scheme + ! 1: effective radius + + integer :: resflag = 1 ! snow effective radius scheme + ! 1: effective radius + + integer :: regflag = 1 ! graupel effective radius scheme + ! 1: effective radius + + integer :: radr_flag = 1 ! radar reflectivity for rain + ! 1: Mark Stoelinga (2005) + ! 2: Smith et al. (1975), Tong and Xue (2005) + ! 3: Marshall-Palmer formula (https://en.wikipedia.org/wiki/DBZ_(meteorology)) + + integer :: rads_flag = 1 ! radar reflectivity for snow + ! 1: Mark Stoelinga (2005) + ! 2: Smith et al. (1975), Tong and Xue (2005) + ! 3: Marshall-Palmer formula (https://en.wikipedia.org/wiki/DBZ_(meteorology)) + + integer :: radg_flag = 1 ! radar reflectivity for graupel + ! 1: Mark Stoelinga (2005) + ! 2: Smith et al. (1975), Tong and Xue (2005) + ! 3: Marshall-Palmer formula (https://en.wikipedia.org/wiki/DBZ_(meteorology)) + + integer :: sedflag = 1 ! sedimentation scheme + ! 1: implicit scheme + ! 2: explicit scheme + ! 3: lagrangian scheme + ! 4: combined implicit and lagrangian scheme + + integer :: vdiffflag = 1 ! wind difference scheme in accretion + ! 1: Wisner et al. (1972) + ! 2: Mizuno (1990) + ! 3: Murakami (1990) + + logical :: do_sedi_uv = .true. ! transport of horizontal momentum in sedimentation + logical :: do_sedi_w = .true. ! transport of vertical momentum in sedimentation + logical :: do_sedi_heat = .true. ! transport of heat in sedimentation + logical :: do_sedi_melt = .true. ! melt cloud ice, snow, and graupel during sedimentation + + logical :: do_qa = .true. ! do inline cloud fraction + logical :: rad_snow = .true. ! include snow in cloud fraciton calculation + logical :: rad_graupel = .true. ! include graupel in cloud fraction calculation + logical :: rad_rain = .true. ! include rain in cloud fraction calculation + logical :: do_cld_adj = .false. ! do cloud fraction adjustment + + logical :: z_slope_liq = .true. ! use linear mono slope for autocconversions + logical :: z_slope_ice = .true. ! use linear mono slope for autocconversions + + logical :: use_rhc_cevap = .false. ! cap of rh for cloud water evaporation + logical :: use_rhc_revap = .false. ! cap of rh for rain evaporation + + logical :: const_vw = .false. ! if .ture., the constants are specified by v * _fac + logical :: const_vi = .false. ! if .ture., the constants are specified by v * _fac + logical :: const_vs = .false. ! if .ture., the constants are specified by v * _fac + logical :: const_vg = .false. ! if .ture., the constants are specified by v * _fac + logical :: const_vr = .false. ! if .ture., the constants are specified by v * _fac + + logical :: liq_ice_combine = .false. ! combine all liquid water, combine all solid water + logical :: snow_grauple_combine = .true. ! combine snow and graupel + + logical :: prog_ccn = .false. ! do prognostic ccn (Yi Ming's method) + + logical :: fix_negative = .true. ! fix negative water species + + logical :: do_cond_timescale = .false. ! whether to apply a timescale to condensation + + logical :: do_hail = .false. ! use hail parameters instead of graupel + + logical :: consv_checker = .false. ! turn on energy and water conservation checker + + logical :: do_warm_rain_mp = .false. ! do warm rain cloud microphysics only + + logical :: do_wbf = .false. ! do Wegener Bergeron Findeisen process + + logical :: do_psd_water_fall = .false. ! calculate cloud water terminal velocity based on PSD + logical :: do_psd_ice_fall = .false. ! calculate cloud ice terminal velocity based on PSD + + logical :: do_psd_water_num = .false. ! calculate cloud water number concentration based on PSD + logical :: do_psd_ice_num = .false. ! calculate cloud ice number concentration based on PSD + + logical :: do_new_acc_water = .false. ! perform the new accretion for cloud water + logical :: do_new_acc_ice = .false. ! perform the new accretion for cloud ice + + logical :: cp_heating = .false. ! update temperature based on constant pressure + + real :: mp_time = 150.0 ! maximum microphysics time step (s) + + real :: n0w_sig = 1.1 ! intercept parameter (significand) of cloud water (Lin et al. 1983) (1/m^4) (Martin et al. 1994) + !real :: n0w_sig = 1.4 ! intercept parameter (significand) of cloud water (Lin et al. 1983) (1/m^4) (Martin et al. 1994) + real :: n0i_sig = 1.3 ! intercept parameter (significand) of cloud ice (Lin et al. 1983) (1/m^4) (McFarquhar et al. 2015) + !real :: n0i_sig = 9.4 ! intercept parameter (significand) of cloud ice (Lin et al. 1983) (1/m^4) (McFarquhar et al. 2015) + real :: n0r_sig = 8.0 ! intercept parameter (significand) of rain (Lin et al. 1983) (1/m^4) (Marshall and Palmer 1948) + real :: n0s_sig = 3.0 ! intercept parameter (significand) of snow (Lin et al. 1983) (1/m^4) (Gunn and Marshall 1958) + real :: n0g_sig = 4.0 ! intercept parameter (significand) of graupel (Rutledge and Hobbs 1984) (1/m^4) (Houze et al. 1979) + real :: n0h_sig = 4.0 ! intercept parameter (significand) of hail (Lin et al. 1983) (1/m^4) (Federer and Waldvogel 1975) + + real :: n0w_exp = 41 ! intercept parameter (exponent) of cloud water (Lin et al. 1983) (1/m^4) (Martin et al. 1994) + !real :: n0w_exp = 91 ! intercept parameter (exponent) of cloud water (Lin et al. 1983) (1/m^4) (Martin et al. 1994) + real :: n0i_exp = 18 ! intercept parameter (exponent) of cloud ice (Lin et al. 1983) (1/m^4) (McFarquhar et al. 2015) + !real :: n0i_exp = 17 ! intercept parameter (exponent) of cloud ice (Lin et al. 1983) (1/m^4) (McFarquhar et al. 2015) + real :: n0r_exp = 6 ! intercept parameter (exponent) of rain (Lin et al. 1983) (1/m^4) (Marshall and Palmer 1948) + real :: n0s_exp = 6 ! intercept parameter (exponent) of snow (Lin et al. 1983) (1/m^4) (Gunn and Marshall 1958) + real :: n0g_exp = 6 ! intercept parameter (exponent) of graupel (Rutledge and Hobbs 1984) (1/m^4) (Houze et al. 1979) + real :: n0h_exp = 4 ! intercept parameter (exponent) of hail (Lin et al. 1983) (1/m^4) (Federer and Waldvogel 1975) + + real :: muw = 6.0 ! shape parameter of cloud water in Gamma distribution (Martin et al. 1994) + !real :: muw = 16.0 ! shape parameter of cloud water in Gamma distribution (Martin et al. 1994) + real :: mui = 3.35 ! shape parameter of cloud ice in Gamma distribution (McFarquhar et al. 2015) + !real :: mui = 3.54 ! shape parameter of cloud ice in Gamma distribution (McFarquhar et al. 2015) + real :: mur = 1.0 ! shape parameter of rain in Gamma distribution (Marshall and Palmer 1948) + real :: mus = 1.0 ! shape parameter of snow in Gamma distribution (Gunn and Marshall 1958) + real :: mug = 1.0 ! shape parameter of graupel in Gamma distribution (Houze et al. 1979) + real :: muh = 1.0 ! shape parameter of hail in Gamma distribution (Federer and Waldvogel 1975) + + real :: alinw = 3.e7 ! "a" in Lin et al. (1983) for cloud water (Ikawa and Saito 1990) + real :: alini = 7.e2 ! "a" in Lin et al. (1983) for cloud ice (Ikawa and Saita 1990) + real :: alinr = 842.0 ! "a" in Lin et al. (1983) for rain (Liu and Orville 1969) + real :: alins = 4.8 ! "a" in Lin et al. (1983) for snow (straka 2009) + real :: aling = 1.0 ! "a" in Lin et al. (1983), similar to a, but for graupel (Pruppacher and Klett 2010) + real :: alinh = 1.0 ! "a" in Lin et al. (1983), similar to a, but for hail (Pruppacher and Klett 2010) + + real :: blinw = 2.0 ! "b" in Lin et al. (1983) for cloud water (Ikawa and Saito 1990) + real :: blini = 1.0 ! "b" in Lin et al. (1983) for cloud ice (Ikawa and Saita 1990) + real :: blinr = 0.8 ! "b" in Lin et al. (1983) for rain (Liu and Orville 1969) + real :: blins = 0.25 ! "b" in Lin et al. (1983) for snow (straka 2009) + real :: bling = 0.5 ! "b" in Lin et al. (1983), similar to b, but for graupel (Pruppacher and Klett 2010) + real :: blinh = 0.5 ! "b" in Lin et al. (1983), similar to b, but for hail (Pruppacher and Klett 2010) + + real :: tice_mlt = 273.16 ! can set ice melting temperature to 268 based on observation (Kay et al. 2016) (K) + + real :: t_min = 178.0 ! minimum temperature to freeze - dry all water vapor (K) + real :: t_sub = 184.0 ! minimum temperature for sublimation of cloud ice (K) + + real :: rh_inc = 0.25 ! rh increment for complete evaporation of cloud water and cloud ice + real :: rh_inr = 0.25 ! rh increment for minimum evaporation of rain + real :: rh_ins = 0.25 ! rh increment for sublimation of snow + + real :: tau_r2g = 900.0 ! rain freezing to graupel time scale (s) + real :: tau_i2s = 1000.0 ! cloud ice to snow autoconversion time scale (s) + real :: tau_l2r = 900.0 ! cloud water to rain autoconversion time scale (s) + real :: tau_v2l = 150.0 ! water vapor to cloud water condensation time scale (s) + real :: tau_l2v = 300.0 ! cloud water to water vapor evaporation time scale (s) + real :: tau_revp = 0.0 ! rain evaporation time scale (s) + real :: tau_imlt = 1200.0 ! cloud ice melting time scale (s) + real :: tau_smlt = 900.0 ! snow melting time scale (s) + real :: tau_gmlt = 600.0 ! graupel melting time scale (s) + real :: tau_wbf = 300.0 ! graupel melting time scale (s) + + real :: dw_land = 0.20 ! base value for subgrid deviation / variability over land + real :: dw_ocean = 0.10 ! base value for subgrid deviation / variability over ocean + + real :: ccn_o = 90.0 ! ccn over ocean (1/cm^3) + real :: ccn_l = 270.0 ! ccn over land (1/cm^3) + + real :: rthresh = 10.0e-6 ! critical cloud drop radius (micron) for autoconversion + + real :: cld_min = 0.05 ! minimum cloud fraction + + real :: qi_lim = 1.0 ! cloud ice limiter (0: no, 1: full, >1: extra) to prevent large ice build up + + real :: ql_mlt = 2.0e-3 ! maximum cloud water allowed from melted cloud ice (kg/kg) + real :: qs_mlt = 1.0e-6 ! maximum cloud water allowed from melted snow (kg/kg) + + real :: ql_gen = 1.0e-3 ! maximum cloud water generation during remapping step (kg/kg) + + real :: ql0_max = 2.0e-3 ! maximum cloud water value (autoconverted to rain) (kg/kg) + real :: qi0_max = 1.0e-4 ! maximum cloud ice value (autoconverted to snow) (kg/m^3) + + real :: qi0_crt = 1.0e-4 ! cloud ice to snow autoconversion threshold (kg/m^3) + real :: qs0_crt = 1.0e-3 ! snow to graupel autoconversion threshold (0.6e-3 in Purdue Lin scheme) (kg/m^3) + + real :: c_paut = 0.55 ! cloud water to rain autoconversion efficiency + real :: c_psacw = 1.0 ! cloud water to snow accretion efficiency + real :: c_psaci = 0.05 ! cloud ice to snow accretion efficiency (was 0.1 in ZETAC) + real :: c_pracw = 0.8 ! cloud water to rain accretion efficiency + real :: c_praci = 1.0 ! cloud ice to rain accretion efficiency + real :: c_pgacw = 1.0 ! cloud water to graupel accretion efficiency + real :: c_pgaci = 0.05 ! cloud ice to graupel accretion efficiency (was 0.1 in ZETAC) + real :: c_pracs = 1.0 ! snow to rain accretion efficiency + real :: c_psacr = 1.0 ! rain to snow accretion efficiency + real :: c_pgacr = 1.0 ! rain to graupel accretion efficiency + real :: c_pgacs = 0.01 ! snow to graupel accretion efficiency (was 0.1 in ZETAC) + + real :: is_fac = 0.2 ! cloud ice sublimation temperature factor + real :: ss_fac = 0.2 ! snow sublimation temperature factor + real :: gs_fac = 0.2 ! graupel sublimation temperature factor + + real :: rh_fac = 10.0 ! cloud water condensation / evaporation relative humidity factor + + real :: sed_fac = 1.0 ! coefficient for sedimentation fall, scale from 1.0 (implicit) to 0.0 (lagrangian) + + real :: vw_fac = 1.0 + real :: vi_fac = 1.0 ! IFS: if const_vi: 1 / 3 + real :: vs_fac = 1.0 ! IFS: if const_vs: 1. + real :: vg_fac = 1.0 ! IFS: if const_vg: 2. + real :: vr_fac = 1.0 ! IFS: if const_vr: 4. + + real :: vw_max = 0.01 ! maximum fall speed for cloud water (m/s) + real :: vi_max = 0.5 ! maximum fall speed for cloud ice (m/s) + real :: vs_max = 5.0 ! maximum fall speed for snow (m/s) + real :: vg_max = 8.0 ! maximum fall speed for graupel (m/s) + real :: vr_max = 12.0 ! maximum fall speed for rain (m/s) + + real :: xr_a = 0.25 ! p value in Xu and Randall (1996) + real :: xr_b = 100.0 ! alpha_0 value in Xu and Randall (1996) + real :: xr_c = 0.49 ! gamma value in Xu and Randall (1996) + + real :: te_err = 1.e-5 ! 64bit: 1.e-14, 32bit: 1.e-7; turn off to save computer time + real :: tw_err = 1.e-8 ! 64bit: 1.e-14, 32bit: 1.e-7; turn off to save computer time + + real :: rh_thres = 0.75 ! minimum relative humidity for cloud fraction + real :: rhc_cevap = 0.85 ! maximum relative humidity for cloud water evaporation + real :: rhc_revap = 0.85 ! maximum relative humidity for rain evaporation + + real :: f_dq_p = 1.0 ! cloud fraction adjustment for supersaturation + real :: f_dq_m = 1.0 ! cloud fraction adjustment for undersaturation + + real :: fi2s_fac = 1.0 ! maximum sink of cloud ice to form snow: 0-1 + real :: fi2g_fac = 1.0 ! maximum sink of cloud ice to form graupel: 0-1 + real :: fs2g_fac = 1.0 ! maximum sink of snow to form graupel: 0-1 + + real :: beta = 1.22 ! defined in Heymsfield and Mcfarquhar (1996) + + real :: rewmin = 5.0, rewmax = 15.0 ! minimum and maximum effective radius for cloud water (micron) + real :: reimin = 10.0, reimax = 150.0 ! minimum and maximum effective radius for cloud ice (micron) + real :: rermin = 15.0, rermax = 10000.0 ! minimum and maximum effective radius for rain (micron) + real :: resmin = 150.0, resmax = 10000.0 ! minimum and maximum effective radius for snow (micron) + real :: regmin = 150.0, regmax = 10000.0 ! minimum and maximum effective radius for graupel + !real :: rewmax = 15.0, rermin = 15.0 ! Kokhanovsky (2004) + + real :: rewfac = 1.0 ! this is a tuning parameter to compromise the inconsistency between + ! GFDL MP's PSD and cloud water radiative property's PSD assumption. + ! after the cloud water radiative property's PSD is rebuilt, + ! this parameter should be 1.0. + real :: reifac = 1.0 ! this is a tuning parameter to compromise the inconsistency between + ! GFDL MP's PSD and cloud ice radiative property's PSD assumption. + ! after the cloud ice radiative property's PSD is rebuilt, + ! this parameter should be 1.0. + + ! ----------------------------------------------------------------------- + ! local shared variables + ! ----------------------------------------------------------------------- + + real :: acco (3, 10), acc (20) + real :: cracs, csacr, cgacr, cgacs, csacw, craci, csaci, cgacw, cgaci, cracw + real :: cssub (5), cgsub (5), crevp (5), cgfr (2), csmlt (4), cgmlt (4) + + real :: t_wfr, fac_rc, c_air, c_vap, d0_vap + + real (kind = r8) :: lv00, li00, li20, cpaut + real (kind = r8) :: d1_vap, d1_ice, c1_vap, c1_liq, c1_ice + real (kind = r8) :: normw, normr, normi, norms, normg, normh + real (kind = r8) :: expow, expor, expoi, expos, expog, expoh + real (kind = r8) :: pcaw, pcar, pcai, pcas, pcag, pcah + real (kind = r8) :: pcbw, pcbr, pcbi, pcbs, pcbg, pcbh + real (kind = r8) :: edaw, edar, edai, edas, edag, edah + real (kind = r8) :: edbw, edbr, edbi, edbs, edbg, edbh + real (kind = r8) :: oeaw, oear, oeai, oeas, oeag, oeah + real (kind = r8) :: oebw, oebr, oebi, oebs, oebg, oebh + real (kind = r8) :: rraw, rrar, rrai, rras, rrag, rrah + real (kind = r8) :: rrbw, rrbr, rrbi, rrbs, rrbg, rrbh + real (kind = r8) :: tvaw, tvar, tvai, tvas, tvag, tvah + real (kind = r8) :: tvbw, tvbr, tvbi, tvbs, tvbg, tvbh + + real, allocatable :: table0 (:), table1 (:), table2 (:), table3 (:), table4 (:) + real, allocatable :: des0 (:), des1 (:), des2 (:), des3 (:), des4 (:) + + ! ----------------------------------------------------------------------- + ! namelist + ! ----------------------------------------------------------------------- + + namelist / gfdl_mp_nml / & + t_min, t_sub, tau_r2g, tau_smlt, tau_gmlt, dw_land, dw_ocean, vw_fac, vi_fac, & + vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vw_max, vi_max, vs_max, & + vg_max, vr_max, qs_mlt, qs0_crt, ql0_max, qi0_max, qi0_crt, ifflag, & + rh_inc, rh_ins, rh_inr, const_vw, const_vi, const_vs, const_vg, const_vr, rthresh, & + ccn_l, ccn_o, igflag, c_paut, tau_imlt, tau_v2l, tau_l2v, tau_i2s, & + tau_l2r, qi_lim, ql_gen, do_hail, inflag, c_psacw, c_psaci, c_pracs, & + c_psacr, c_pgacr, c_pgacs, c_pgacw, c_pgaci, z_slope_liq, z_slope_ice, & + prog_ccn, c_pracw, c_praci, rad_snow, rad_graupel, rad_rain, cld_min, & + sedflag, sed_fac, do_sedi_uv, do_sedi_w, do_sedi_heat, icloud_f, & + irain_f, xr_a, xr_b, xr_c, ntimes, tau_revp, tice_mlt, do_cond_timescale, & + mp_time, consv_checker, te_err, tw_err, use_rhc_cevap, use_rhc_revap, tau_wbf, & + do_warm_rain_mp, rh_thres, f_dq_p, f_dq_m, do_cld_adj, rhc_cevap, & + rhc_revap, beta, liq_ice_combine, rewflag, reiflag, rerflag, resflag, & + regflag, rewmin, rewmax, reimin, reimax, rermin, rermax, resmin, & + resmax, regmin, regmax, fs2g_fac, fi2s_fac, fi2g_fac, do_sedi_melt, & + radr_flag, rads_flag, radg_flag, do_wbf, do_psd_water_fall, do_psd_ice_fall, & + n0w_sig, n0i_sig, n0r_sig, n0s_sig, n0g_sig, n0h_sig, n0w_exp, n0i_exp, & + n0r_exp, n0s_exp, n0g_exp, n0h_exp, muw, mui, mur, mus, mug, muh, & + alinw, alini, alinr, alins, aling, alinh, blinw, blini, blinr, blins, bling, blinh, & + do_new_acc_water, do_new_acc_ice, is_fac, ss_fac, gs_fac, rh_fac, & + snow_grauple_combine, do_psd_water_num, do_psd_ice_num, vdiffflag, rewfac, reifac, & + cp_heating + +contains + +! ======================================================================= +! GFDL cloud microphysics initialization +! ======================================================================= + +subroutine gfdl_cld_mp_init (input_nml_file, logunit, hydrostatic) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + logical, intent (in) :: hydrostatic + + integer, intent (in) :: logunit + + character (len = *), intent (in) :: input_nml_file (:) + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + logical :: exists + + ! ----------------------------------------------------------------------- + ! read namelist + ! ----------------------------------------------------------------------- + + read (input_nml_file, nml = gfdl_mp_nml) + + ! ----------------------------------------------------------------------- + ! write namelist to log file + ! ----------------------------------------------------------------------- + + write (logunit, *) " ================================================================== " + write (logunit, *) "gfdl_mp_mod" + write (logunit, nml = gfdl_mp_nml) + + ! ----------------------------------------------------------------------- + ! initialize microphysics variables + ! ----------------------------------------------------------------------- + + if (.not. tables_are_initialized) call qs_init + + call setup_mp + + ! ----------------------------------------------------------------------- + ! define various heat capacities and latent heat coefficients at 0 deg K + ! ----------------------------------------------------------------------- + + call setup_mhc_lhc (hydrostatic) + +end subroutine gfdl_cld_mp_init + +! ======================================================================= +! GFDL cloud microphysics driver +! ======================================================================= + +subroutine gfdl_cld_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, & + ua, va, delz, delp, gsize, dtm, hs, water, rain, ice, snow, graupel, & + hydrostatic, is, ie, ks, ke, q_con, cappa, consv_te, adj_vmr, te, dte, & + pcw, edw, oew, rrw, tvw, pci, edi, oei, rri, tvi, pcr, edr, oer, rrr, tvr, & + pcs, eds, oes, rrs, tvs, pcg, edg, oeg, rrg, tvg, & + prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, condensation, & + deposition, evaporation, sublimation, last_step, do_inline_mp) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: is, ie, ks, ke + + logical, intent (in) :: hydrostatic, last_step, consv_te, do_inline_mp + + real, intent (in) :: dtm + + real, intent (in), dimension (is:ie) :: hs, gsize + + real, intent (in), dimension (is:ie, ks:ke) :: qnl, qni + + real, intent (inout), dimension (is:ie, ks:ke) :: delp, delz, pt, ua, va, wa, te + real, intent (inout), dimension (is:ie, ks:ke) :: qv, ql, qr, qi, qs, qg, qa + real, intent (inout), dimension (is:ie, ks:ke) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg + + real, intent (inout), dimension (is:, ks:) :: q_con, cappa + + real, intent (inout), dimension (is:ie) :: water, rain, ice, snow, graupel + real, intent (inout), dimension (is:ie) :: condensation, deposition + real, intent (inout), dimension (is:ie) :: evaporation, sublimation + + real, intent (out), dimension (is:ie, ks:ke) :: adj_vmr + real, intent (out), dimension (is:ie, ks:ke) :: pcw, edw, oew, rrw, tvw + real, intent (out), dimension (is:ie, ks:ke) :: pci, edi, oei, rri, tvi + real, intent (out), dimension (is:ie, ks:ke) :: pcr, edr, oer, rrr, tvr + real, intent (out), dimension (is:ie, ks:ke) :: pcs, eds, oes, rrs, tvs + real, intent (out), dimension (is:ie, ks:ke) :: pcg, edg, oeg, rrg, tvg + + real (kind = r8), intent (out), dimension (is:ie) :: dte + + ! ----------------------------------------------------------------------- + ! major cloud microphysics driver + ! ----------------------------------------------------------------------- + + call mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, & + qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, & + gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, pcw, edw, oew, rrw, tvw, & + pci, edi, oei, rri, tvi, pcr, edr, oer, rrr, tvr, pcs, eds, oes, rrs, tvs, & + pcg, edg, oeg, rrg, tvg, prefluxw, prefluxr, prefluxi, & + prefluxs, prefluxg, condensation, deposition, evaporation, sublimation, & + last_step, do_inline_mp, .false., .true.) + +end subroutine gfdl_cld_mp_driver + +! ======================================================================= +! GFDL cloud microphysics end +! ======================================================================= + +subroutine gfdl_cld_mp_end + + implicit none + + ! ----------------------------------------------------------------------- + ! free up memory + ! ----------------------------------------------------------------------- + + deallocate (table0) + deallocate (table1) + deallocate (table2) + deallocate (table3) + deallocate (table4) + deallocate (des0) + deallocate (des1) + deallocate (des2) + deallocate (des3) + deallocate (des4) + + tables_are_initialized = .false. + +end subroutine gfdl_cld_mp_end + +! ======================================================================= +! setup cloud microphysics parameters +! ======================================================================= + +subroutine setup_mp + + implicit none + + integer :: i, k + + real :: gcon, hcon, scm3, pisq, act (20), ace (20), occ (3), aone + + ! ----------------------------------------------------------------------- + ! complete freezing temperature + ! ----------------------------------------------------------------------- + + if (do_warm_rain_mp) then + t_wfr = t_min + else + t_wfr = tice - 40.0 + endif + + ! ----------------------------------------------------------------------- + ! cloud water autoconversion, Hong et al. (2004) + ! ----------------------------------------------------------------------- + + fac_rc = (4. / 3.) * pi * rhow * rthresh ** 3 + + aone = 2. / 9. * (3. / 4.) ** (4. / 3.) / pi ** (1. / 3.) + cpaut = c_paut * aone * grav / visd + + ! ----------------------------------------------------------------------- + ! terminal velocities parameters, Lin et al. (1983) + ! ----------------------------------------------------------------------- + + gcon = (4. * grav * rhog / (3. * cdg * rho0)) ** 0.5 + hcon = (4. * grav * rhoh / (3. * cdh * rho0)) ** 0.5 + + ! ----------------------------------------------------------------------- + ! part of the slope parameters + ! ----------------------------------------------------------------------- + + normw = pi * rhow * n0w_sig * gamma (muw + 3) + normi = pi * rhoi * n0i_sig * gamma (mui + 3) + normr = pi * rhor * n0r_sig * gamma (mur + 3) + norms = pi * rhos * n0s_sig * gamma (mus + 3) + normg = pi * rhog * n0g_sig * gamma (mug + 3) + normh = pi * rhoh * n0h_sig * gamma (muh + 3) + + expow = exp (n0w_exp / (muw + 3) * log (10.)) + expoi = exp (n0i_exp / (mui + 3) * log (10.)) + expor = exp (n0r_exp / (mur + 3) * log (10.)) + expos = exp (n0s_exp / (mus + 3) * log (10.)) + expog = exp (n0g_exp / (mug + 3) * log (10.)) + expoh = exp (n0h_exp / (muh + 3) * log (10.)) + + ! ----------------------------------------------------------------------- + ! parameters for particle concentration (pc), effective diameter (ed), + ! optical extinction (oe), radar reflectivity factor (rr), and + ! mass-weighted terminal velocity (tv) + ! ----------------------------------------------------------------------- + + pcaw = exp (3 / (muw + 3) * log (n0w_sig)) * gamma (muw) * exp (3 * n0w_exp / (muw + 3) * log (10.)) + pcai = exp (3 / (mui + 3) * log (n0i_sig)) * gamma (mui) * exp (3 * n0i_exp / (mui + 3) * log (10.)) + pcar = exp (3 / (mur + 3) * log (n0r_sig)) * gamma (mur) * exp (3 * n0r_exp / (mur + 3) * log (10.)) + pcas = exp (3 / (mus + 3) * log (n0s_sig)) * gamma (mus) * exp (3 * n0s_exp / (mus + 3) * log (10.)) + pcag = exp (3 / (mug + 3) * log (n0g_sig)) * gamma (mug) * exp (3 * n0g_exp / (mug + 3) * log (10.)) + pcah = exp (3 / (muh + 3) * log (n0h_sig)) * gamma (muh) * exp (3 * n0h_exp / (muh + 3) * log (10.)) + + pcbw = exp (muw / (muw + 3) * log (pi * rhow * gamma (muw + 3))) + pcbi = exp (mui / (mui + 3) * log (pi * rhoi * gamma (mui + 3))) + pcbr = exp (mur / (mur + 3) * log (pi * rhor * gamma (mur + 3))) + pcbs = exp (mus / (mus + 3) * log (pi * rhos * gamma (mus + 3))) + pcbg = exp (mug / (mug + 3) * log (pi * rhog * gamma (mug + 3))) + pcbh = exp (muh / (muh + 3) * log (pi * rhoh * gamma (muh + 3))) + + edaw = exp (- 1. / (muw + 3) * log (n0w_sig)) * (muw + 2) * exp (- n0w_exp / (muw + 3) * log (10.)) + edai = exp (- 1. / (mui + 3) * log (n0i_sig)) * (mui + 2) * exp (- n0i_exp / (mui + 3) * log (10.)) + edar = exp (- 1. / (mur + 3) * log (n0r_sig)) * (mur + 2) * exp (- n0r_exp / (mur + 3) * log (10.)) + edas = exp (- 1. / (mus + 3) * log (n0s_sig)) * (mus + 2) * exp (- n0s_exp / (mus + 3) * log (10.)) + edag = exp (- 1. / (mug + 3) * log (n0g_sig)) * (mug + 2) * exp (- n0g_exp / (mug + 3) * log (10.)) + edah = exp (- 1. / (muh + 3) * log (n0h_sig)) * (muh + 2) * exp (- n0h_exp / (muh + 3) * log (10.)) + + edbw = exp (1. / (muw + 3) * log (pi * rhow * gamma (muw + 3))) + edbi = exp (1. / (mui + 3) * log (pi * rhoi * gamma (mui + 3))) + edbr = exp (1. / (mur + 3) * log (pi * rhor * gamma (mur + 3))) + edbs = exp (1. / (mus + 3) * log (pi * rhos * gamma (mus + 3))) + edbg = exp (1. / (mug + 3) * log (pi * rhog * gamma (mug + 3))) + edbh = exp (1. / (muh + 3) * log (pi * rhoh * gamma (muh + 3))) + + oeaw = exp (1. / (muw + 3) * log (n0w_sig)) * pi * gamma (muw + 2) * & + exp (n0w_exp / (muw + 3) * log (10.)) + oeai = exp (1. / (mui + 3) * log (n0i_sig)) * pi * gamma (mui + 2) * & + exp (n0i_exp / (mui + 3) * log (10.)) + oear = exp (1. / (mur + 3) * log (n0r_sig)) * pi * gamma (mur + 2) * & + exp (n0r_exp / (mur + 3) * log (10.)) + oeas = exp (1. / (mus + 3) * log (n0s_sig)) * pi * gamma (mus + 2) * & + exp (n0s_exp / (mus + 3) * log (10.)) + oeag = exp (1. / (mug + 3) * log (n0g_sig)) * pi * gamma (mug + 2) * & + exp (n0g_exp / (mug + 3) * log (10.)) + oeah = exp (1. / (muh + 3) * log (n0h_sig)) * pi * gamma (muh + 2) * & + exp (n0h_exp / (muh + 3) * log (10.)) + + oebw = 2 * exp ((muw + 2) / (muw + 3) * log (pi * rhow * gamma (muw + 3))) + oebi = 2 * exp ((mui + 2) / (mui + 3) * log (pi * rhoi * gamma (mui + 3))) + oebr = 2 * exp ((mur + 2) / (mur + 3) * log (pi * rhor * gamma (mur + 3))) + oebs = 2 * exp ((mus + 2) / (mus + 3) * log (pi * rhos * gamma (mus + 3))) + oebg = 2 * exp ((mug + 2) / (mug + 3) * log (pi * rhog * gamma (mug + 3))) + oebh = 2 * exp ((muh + 2) / (muh + 3) * log (pi * rhoh * gamma (muh + 3))) + + rraw = exp (- 3 / (muw + 3) * log (n0w_sig)) * gamma (muw + 6) * & + exp (- 3 * n0w_exp / (muw + 3) * log (10.)) + rrai = exp (- 3 / (mui + 3) * log (n0i_sig)) * gamma (mui + 6) * & + exp (- 3 * n0i_exp / (mui + 3) * log (10.)) + rrar = exp (- 3 / (mur + 3) * log (n0r_sig)) * gamma (mur + 6) * & + exp (- 3 * n0r_exp / (mur + 3) * log (10.)) + rras = exp (- 3 / (mus + 3) * log (n0s_sig)) * gamma (mus + 6) * & + exp (- 3 * n0s_exp / (mus + 3) * log (10.)) + rrag = exp (- 3 / (mug + 3) * log (n0g_sig)) * gamma (mug + 6) * & + exp (- 3 * n0g_exp / (mug + 3) * log (10.)) + rrah = exp (- 3 / (muh + 3) * log (n0h_sig)) * gamma (muh + 6) * & + exp (- 3 * n0h_exp / (muh + 3) * log (10.)) + + rrbw = exp ((muw + 6) / (muw + 3) * log (pi * rhow * gamma (muw + 3))) + rrbi = exp ((mui + 6) / (mui + 3) * log (pi * rhoi * gamma (mui + 3))) + rrbr = exp ((mur + 6) / (mur + 3) * log (pi * rhor * gamma (mur + 3))) + rrbs = exp ((mus + 6) / (mus + 3) * log (pi * rhos * gamma (mus + 3))) + rrbg = exp ((mug + 6) / (mug + 3) * log (pi * rhog * gamma (mug + 3))) + rrbh = exp ((muh + 6) / (muh + 3) * log (pi * rhoh * gamma (muh + 3))) + + tvaw = exp (- blinw / (muw + 3) * log (n0w_sig)) * alinw * gamma (muw + blinw + 3) * & + exp (- blinw * n0w_exp / (muw + 3) * log (10.)) + tvai = exp (- blini / (mui + 3) * log (n0i_sig)) * alini * gamma (mui + blini + 3) * & + exp (- blini * n0i_exp / (mui + 3) * log (10.)) + tvar = exp (- blinr / (mur + 3) * log (n0r_sig)) * alinr * gamma (mur + blinr + 3) * & + exp (- blinr * n0r_exp / (mur + 3) * log (10.)) + tvas = exp (- blins / (mus + 3) * log (n0s_sig)) * alins * gamma (mus + blins + 3) * & + exp (- blins * n0s_exp / (mus + 3) * log (10.)) + tvag = exp (- bling / (mug + 3) * log (n0g_sig)) * aling * gamma (mug + bling + 3) * & + exp (- bling * n0g_exp / (mug + 3) * log (10.)) * gcon + tvah = exp (- blinh / (muh + 3) * log (n0h_sig)) * alinh * gamma (muh + blinh + 3) * & + exp (- blinh * n0h_exp / (muh + 3) * log (10.)) * hcon + + tvbw = exp (blinw / (muw + 3) * log (pi * rhow * gamma (muw + 3))) * gamma (muw + 3) + tvbi = exp (blini / (mui + 3) * log (pi * rhoi * gamma (mui + 3))) * gamma (mui + 3) + tvbr = exp (blinr / (mur + 3) * log (pi * rhor * gamma (mur + 3))) * gamma (mur + 3) + tvbs = exp (blins / (mus + 3) * log (pi * rhos * gamma (mus + 3))) * gamma (mus + 3) + tvbg = exp (bling / (mug + 3) * log (pi * rhog * gamma (mug + 3))) * gamma (mug + 3) + tvbh = exp (blinh / (muh + 3) * log (pi * rhoh * gamma (muh + 3))) * gamma (muh + 3) + + ! ----------------------------------------------------------------------- + ! Schmidt number, Sc ** (1 / 3) in Lin et al. (1983) + ! ----------------------------------------------------------------------- + + scm3 = exp (1. / 3. * log (visk / vdifu)) + + pisq = pi * pi + + ! ----------------------------------------------------------------------- + ! accretion between cloud water, cloud ice, rain, snow, and graupel or hail, Lin et al. (1983) + ! ----------------------------------------------------------------------- + + cracw = pi * n0r_sig * alinr * gamma (2 + mur + blinr) / & + (4. * exp ((2 + mur + blinr) / (mur + 3) * log (normr))) * & + exp ((1 - blinr) * log (expor)) + craci = pi * n0r_sig * alinr * gamma (2 + mur + blinr) / & + (4. * exp ((2 + mur + blinr) / (mur + 3) * log (normr))) * & + exp ((1 - blinr) * log (expor)) + csacw = pi * n0s_sig * alins * gamma (2 + mus + blins) / & + (4. * exp ((2 + mus + blins) / (mus + 3) * log (norms))) * & + exp ((1 - blins) * log (expos)) + csaci = pi * n0s_sig * alins * gamma (2 + mus + blins) / & + (4. * exp ((2 + mus + blins) / (mus + 3) * log (norms))) * & + exp ((1 - blins) * log (expos)) + if (do_hail) then + cgacw = pi * n0h_sig * alinh * gamma (2 + muh + blinh) * hcon / & + (4. * exp ((2 + muh + blinh) / (muh + 3) * log (normh))) * & + exp ((1 - blinh) * log (expoh)) + cgaci = pi * n0h_sig * alinh * gamma (2 + muh + blinh) * hcon / & + (4. * exp ((2 + muh + blinh) / (muh + 3) * log (normh))) * & + exp ((1 - blinh) * log (expoh)) + else + cgacw = pi * n0g_sig * aling * gamma (2 + mug + bling) * gcon / & + (4. * exp ((2 + mug + bling) / (mug + 3) * log (normg))) * & + exp ((1 - bling) * log (expog)) + cgaci = pi * n0g_sig * aling * gamma (2 + mug + bling) * gcon / & + (4. * exp ((2 + mug + bling) / (mug + 3) * log (normg))) * & + exp ((1 - bling) * log (expog)) + endif + + if (do_new_acc_water) then + + cracw = pisq * n0r_sig * n0w_sig * rhow / 24. + csacw = pisq * n0s_sig * n0w_sig * rhow / 24. + if (do_hail) then + cgacw = pisq * n0h_sig * n0w_sig * rhow / 24. + else + cgacw = pisq * n0g_sig * n0w_sig * rhow / 24. + endif + + endif + + if (do_new_acc_ice) then + + craci = pisq * n0r_sig * n0i_sig * rhoi / 24. + csaci = pisq * n0s_sig * n0i_sig * rhoi / 24. + if (do_hail) then + cgaci = pisq * n0h_sig * n0i_sig * rhoi / 24. + else + cgaci = pisq * n0g_sig * n0i_sig * rhoi / 24. + endif + + endif + + cracw = cracw * c_pracw + craci = craci * c_praci + csacw = csacw * c_psacw + csaci = csaci * c_psaci + cgacw = cgacw * c_pgacw + cgaci = cgaci * c_pgaci + + ! ----------------------------------------------------------------------- + ! accretion between cloud water, cloud ice, rain, snow, and graupel or hail, Lin et al. (1983) + ! ----------------------------------------------------------------------- + + cracs = pisq * n0r_sig * n0s_sig * rhos / 24. + csacr = pisq * n0s_sig * n0r_sig * rhor / 24. + if (do_hail) then + cgacr = pisq * n0h_sig * n0r_sig * rhor / 24. + cgacs = pisq * n0h_sig * n0s_sig * rhos / 24. + else + cgacr = pisq * n0g_sig * n0r_sig * rhor / 24. + cgacs = pisq * n0g_sig * n0s_sig * rhos / 24. + endif + + cracs = cracs * c_pracs + csacr = csacr * c_psacr + cgacr = cgacr * c_pgacr + cgacs = cgacs * c_pgacs + + ! act / ace / acc: + ! 1 - 2: racs (s - r) + ! 3 - 4: sacr (r - s) + ! 5 - 6: gacr (r - g) + ! 7 - 8: gacs (s - g) + ! 9 - 10: racw (w - r) + ! 11 - 12: raci (i - r) + ! 13 - 14: sacw (w - s) + ! 15 - 16: saci (i - s) + ! 17 - 18: sacw (w - g) + ! 19 - 20: saci (i - g) + + act (1) = norms + act (2) = normr + act (3) = act (2) + act (4) = act (1) + act (5) = act (2) + if (do_hail) then + act (6) = normh + else + act (6) = normg + endif + act (7) = act (1) + act (8) = act (6) + act (9) = normw + act (10) = act (2) + act (11) = normi + act (12) = act (2) + act (13) = act (9) + act (14) = act (1) + act (15) = act (11) + act (16) = act (1) + act (17) = act (9) + act (18) = act (6) + act (19) = act (11) + act (20) = act (6) + + ace (1) = expos + ace (2) = expor + ace (3) = ace (2) + ace (4) = ace (1) + ace (5) = ace (2) + if (do_hail) then + ace (6) = expoh + else + ace (6) = expog + endif + ace (7) = ace (1) + ace (8) = ace (6) + ace (9) = expow + ace (10) = ace (2) + ace (11) = expoi + ace (12) = ace (2) + ace (13) = ace (9) + ace (14) = ace (1) + ace (15) = ace (11) + ace (16) = ace (1) + ace (17) = ace (9) + ace (18) = ace (6) + ace (19) = ace (11) + ace (20) = ace (6) + + acc (1) = mus + acc (2) = mur + acc (3) = acc (2) + acc (4) = acc (1) + acc (5) = acc (2) + if (do_hail) then + acc (6) = muh + else + acc (6) = mug + endif + acc (7) = acc (1) + acc (8) = acc (6) + acc (9) = muw + acc (10) = acc (2) + acc (11) = mui + acc (12) = acc (2) + acc (13) = acc (9) + acc (14) = acc (1) + acc (15) = acc (11) + acc (16) = acc (1) + acc (17) = acc (9) + acc (18) = acc (6) + acc (19) = acc (11) + acc (20) = acc (6) + + occ (1) = 1. + occ (2) = 2. + occ (3) = 1. + + do i = 1, 3 + do k = 1, 10 + acco (i, k) = occ (i) * gamma (6 + acc (2 * k - 1) - i) * gamma (acc (2 * k) + i - 1) / & + (exp ((6 + acc (2 * k - 1) - i) / (acc (2 * k - 1) + 3) * log (act (2 * k - 1))) * & + exp ((acc (2 * k) + i - 1) / (acc (2 * k) + 3) * log (act (2 * k)))) * & + exp ((i - 3) * log (ace (2 * k - 1))) * exp ((4 - i) * log (ace (2 * k))) + enddo + enddo + + ! ----------------------------------------------------------------------- + ! rain evaporation, snow sublimation, and graupel or hail sublimation, Lin et al. (1983) + ! ----------------------------------------------------------------------- + + crevp (1) = 2. * pi * vdifu * tcond * rvgas * n0r_sig * gamma (1 + mur) / & + exp ((1 + mur) / (mur + 3) * log (normr)) * exp (2.0 * log (expor)) + crevp (2) = 0.78 + crevp (3) = 0.31 * scm3 * sqrt (alinr / visk) * gamma ((3 + 2 * mur + blinr) / 2) / & + exp ((3 + 2 * mur + blinr) / (mur + 3) / 2 * log (normr)) * & + exp ((1 + mur) / (mur + 3) * log (normr)) / gamma (1 + mur) * & + exp ((- 1 - blinr) / 2. * log (expor)) + crevp (4) = tcond * rvgas + crevp (5) = vdifu + + cssub (1) = 2. * pi * vdifu * tcond * rvgas * n0s_sig * gamma (1 + mus) / & + exp ((1 + mus) / (mus + 3) * log (norms)) * exp (2.0 * log (expos)) + cssub (2) = 0.78 + cssub (3) = 0.31 * scm3 * sqrt (alins / visk) * gamma ((3 + 2 * mus + blins) / 2) / & + exp ((3 + 2 * mus + blins) / (mus + 3) / 2 * log (norms)) * & + exp ((1 + mus) / (mus + 3) * log (norms)) / gamma (1 + mus) * & + exp ((- 1 - blins) / 2. * log (expos)) + cssub (4) = tcond * rvgas + cssub (5) = vdifu + + if (do_hail) then + cgsub (1) = 2. * pi * vdifu * tcond * rvgas * n0h_sig * gamma (1 + muh) / & + exp ((1 + muh) / (muh + 3) * log (normh)) * exp (2.0 * log (expoh)) + cgsub (2) = 0.78 + cgsub (3) = 0.31 * scm3 * sqrt (alinh * hcon / visk) * gamma ((3 + 2 * muh + blinh) / 2) / & + exp (1. / (muh + 3) * (3 + 2 * muh + blinh) / 2 * log (normh)) * & + exp (1. / (muh + 3) * (1 + muh) * log (normh)) / gamma (1 + muh) * & + exp ((- 1 - blinh) / 2. * log (expoh)) + else + cgsub (1) = 2. * pi * vdifu * tcond * rvgas * n0g_sig * gamma (1 + mug) / & + exp ((1 + mug) / (mug + 3) * log (normg)) * exp (2.0 * log (expog)) + cgsub (2) = 0.78 + cgsub (3) = 0.31 * scm3 * sqrt (aling * gcon / visk) * gamma ((3 + 2 * mug + bling) / 2) / & + exp ((3 + 2 * mug + bling) / (mug + 3) / 2 * log (normg)) * & + exp ((1 + mug) / (mug + 3) * log (normg)) / gamma (1 + mug) * & + exp ((- 1 - bling) / 2. * log (expog)) + endif + cgsub (4) = tcond * rvgas + cgsub (5) = vdifu + + ! ----------------------------------------------------------------------- + ! snow melting, Lin et al. (1983) + ! ----------------------------------------------------------------------- + + csmlt (1) = 2. * pi * tcond * n0s_sig * gamma (1 + mus) / & + exp ((1 + mus) / (mus + 3) * log (norms)) * exp (2.0 * log (expos)) + csmlt (2) = 2. * pi * vdifu * n0s_sig * gamma (1 + mus) / & + exp ((1 + mus) / (mus + 3) * log (norms)) * exp (2.0 * log (expos)) + csmlt (3) = cssub (2) + csmlt (4) = cssub (3) + + ! ----------------------------------------------------------------------- + ! graupel or hail melting, Lin et al. (1983) + ! ----------------------------------------------------------------------- + + if (do_hail) then + cgmlt (1) = 2. * pi * tcond * n0h_sig * gamma (1 + muh) / & + exp ((1 + muh) / (muh + 3) * log (normh)) * exp (2.0 * log (expoh)) + cgmlt (2) = 2. * pi * vdifu * n0h_sig * gamma (1 + muh) / & + exp ((1 + muh) / (muh + 3) * log (normh)) * exp (2.0 * log (expoh)) + else + cgmlt (1) = 2. * pi * tcond * n0g_sig * gamma (1 + mug) / & + exp ((1 + mug) / (mug + 3) * log (normg)) * exp (2.0 * log (expog)) + cgmlt (2) = 2. * pi * vdifu * n0g_sig * gamma (1 + mug) / & + exp ((1 + mug) / (mug + 3) * log (normg)) * exp (2.0 * log (expog)) + endif + cgmlt (3) = cgsub (2) + cgmlt (4) = cgsub (3) + + ! ----------------------------------------------------------------------- + ! rain freezing, Lin et al. (1983) + ! ----------------------------------------------------------------------- + + cgfr (1) = 1.e2 / 36 * pisq * n0r_sig * rhor * gamma (6 + mur) / & + exp ((6 + mur) / (mur + 3) * log (normr)) * exp (- 3.0 * log (expor)) + cgfr (2) = 0.66 + +end subroutine setup_mp + +! ======================================================================= +! define various heat capacities and latent heat coefficients at 0 deg K +! ======================================================================= + +subroutine setup_mhc_lhc (hydrostatic) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + logical, intent (in) :: hydrostatic + + if (hydrostatic) then + c_air = cp_air + c_vap = cp_vap + do_sedi_w = .false. + else + c_air = cv_air + c_vap = cv_vap + endif + d0_vap = c_vap - c_liq + + ! scaled constants (to reduce float point errors for 32-bit) + + d1_vap = d0_vap / c_air + d1_ice = dc_ice / c_air + + lv00 = (hlv - d0_vap * tice) / c_air + li00 = (hlf - dc_ice * tice) / c_air + li20 = lv00 + li00 + + c1_vap = c_vap / c_air + c1_liq = c_liq / c_air + c1_ice = c_ice / c_air + +end subroutine setup_mhc_lhc + +! ======================================================================= +! major cloud microphysics driver +! ======================================================================= + +subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & + qa, qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, & + gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, pcw, edw, oew, rrw, tvw, & + pci, edi, oei, rri, tvi, pcr, edr, oer, rrr, tvr, pcs, eds, oes, rrs, tvs, & + pcg, edg, oeg, rrg, tvg, prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, & + condensation, deposition, evaporation, sublimation, last_step, do_inline_mp, & + do_mp_fast, do_mp_full) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: is, ie, ks, ke + + logical, intent (in) :: hydrostatic, last_step, consv_te, do_inline_mp + logical, intent (in) :: do_mp_fast, do_mp_full + + real, intent (in) :: dtm + + real, intent (in), dimension (is:ie) :: gsize, hs + + real, intent (in), dimension (is:ie, ks:ke) :: qnl, qni + + real, intent (inout), dimension (is:ie, ks:ke) :: delp, delz, pt, ua, va, wa + real, intent (inout), dimension (is:ie, ks:ke) :: qv, ql, qr, qi, qs, qg, qa + real, intent (inout), dimension (is:ie, ks:ke) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg + + real, intent (inout), dimension (is:, ks:) :: q_con, cappa + + real, intent (inout), dimension (is:ie) :: water, rain, ice, snow, graupel + real, intent (inout), dimension (is:ie) :: condensation, deposition + real, intent (inout), dimension (is:ie) :: evaporation, sublimation + + real, intent (out), dimension (is:ie, ks:ke) :: te, adj_vmr + real, intent (out), dimension (is:ie, ks:ke) :: pcw, edw, oew, rrw, tvw + real, intent (out), dimension (is:ie, ks:ke) :: pci, edi, oei, rri, tvi + real, intent (out), dimension (is:ie, ks:ke) :: pcr, edr, oer, rrr, tvr + real, intent (out), dimension (is:ie, ks:ke) :: pcs, eds, oes, rrs, tvs + real, intent (out), dimension (is:ie, ks:ke) :: pcg, edg, oeg, rrg, tvg + + real (kind = r8), intent (out), dimension (is:ie) :: dte + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: i, k, n + + real :: rh_adj, rh_rain, ccn0, cin0, cond, q1, q2 + real :: convt, dts, q_cond, t_lnd, t_ocn, h_var, tmp, nl, ni + + real, dimension (ks:ke) :: q_liq, q_sol, dp, dz, dp0 + real, dimension (ks:ke) :: qvz, qlz, qrz, qiz, qsz, qgz, qaz + real, dimension (ks:ke) :: den, pz, denfac, ccn, cin + real, dimension (ks:ke) :: u, v, w + + real (kind = r8) :: con_r8, c8, cp8 + + real (kind = r8), dimension (is:ie, ks:ke) :: te_beg_d, te_end_d, tw_beg_d, tw_end_d + real (kind = r8), dimension (is:ie, ks:ke) :: te_beg_m, te_end_m, tw_beg_m, tw_end_m + + real (kind = r8), dimension (is:ie) :: te_b_beg_d, te_b_end_d, tw_b_beg_d, tw_b_end_d, te_loss + real (kind = r8), dimension (is:ie) :: te_b_beg_m, te_b_end_m, tw_b_beg_m, tw_b_end_m + + real (kind = r8), dimension (ks:ke) :: tz, tzuv, tzw + + ! ----------------------------------------------------------------------- + ! time steps + ! ----------------------------------------------------------------------- + + ntimes = max (ntimes, int (dtm / min (dtm, mp_time))) + dts = dtm / real (ntimes) + + ! ----------------------------------------------------------------------- + ! initialization of total energy difference and condensation diag + ! ----------------------------------------------------------------------- + + dte = 0.0 + cond = 0.0 + adj_vmr = 1.0 + + ! ----------------------------------------------------------------------- + ! unit convert to mm/day + ! ----------------------------------------------------------------------- + + convt = 86400. * rgrav / dts + + do i = is, ie + + ! ----------------------------------------------------------------------- + ! conversion of temperature + ! ----------------------------------------------------------------------- + + if (do_inline_mp) then + do k = ks, ke + q_cond = ql (i, k) + qr (i, k) + qi (i, k) + qs (i, k) + qg (i, k) + tz (k) = pt (i, k) / ((1. + zvir * qv (i, k)) * (1. - q_cond)) + enddo + else + do k = ks, ke + tz (k) = pt (i, k) + enddo + endif + + ! ----------------------------------------------------------------------- + ! calculate base total energy + ! ----------------------------------------------------------------------- + + if (consv_te) then + if (hydrostatic) then + do k = ks, ke + te (i, k) = - c_air * tz (k) * delp (i, k) + enddo + else + do k = ks, ke + te (i, k) = - mte (qv (i, k), ql (i, k), qr (i, k), qi (i, k), & + qs (i, k), qg (i, k), tz (k), delp (i, k), .true.) * grav + enddo + endif + endif + + ! ----------------------------------------------------------------------- + ! total energy checker + ! ----------------------------------------------------------------------- + + if (consv_checker) then + call mtetw (ks, ke, qv (i, :), ql (i, :), qr (i, :), qi (i, :), & + qs (i, :), qg (i, :), tz, ua (i, :), va (i, :), wa (i, :), & + delp (i, :), gsize (i), dte (i), 0.0, water (i), rain (i), & + ice (i), snow (i), graupel (i), 0.0, 0.0, dtm, te_beg_m (i, :), & + tw_beg_m (i, :), te_b_beg_m (i), tw_b_beg_m (i), .true., hydrostatic) + endif + + do k = ks, ke + + ! ----------------------------------------------------------------------- + ! convert specific ratios to mass mixing ratios + ! ----------------------------------------------------------------------- + + qvz (k) = qv (i, k) + qlz (k) = ql (i, k) + qrz (k) = qr (i, k) + qiz (k) = qi (i, k) + qsz (k) = qs (i, k) + qgz (k) = qg (i, k) + qaz (k) = qa (i, k) + + if (do_inline_mp) then + q_cond = qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k) + con_r8 = one_r8 - (qvz (k) + q_cond) + else + con_r8 = one_r8 - qvz (k) + endif + + dp0 (k) = delp (i, k) + dp (k) = delp (i, k) * con_r8 + con_r8 = one_r8 / con_r8 + qvz (k) = qvz (k) * con_r8 + qlz (k) = qlz (k) * con_r8 + qrz (k) = qrz (k) * con_r8 + qiz (k) = qiz (k) * con_r8 + qsz (k) = qsz (k) * con_r8 + qgz (k) = qgz (k) * con_r8 + + ! ----------------------------------------------------------------------- + ! dry air density and layer-mean pressure thickness + ! ----------------------------------------------------------------------- + + dz (k) = delz (i, k) + den (k) = - dp (k) / (grav * dz (k)) + pz (k) = den (k) * rdgas * tz (k) + + ! ----------------------------------------------------------------------- + ! for sedi_momentum transport + ! ----------------------------------------------------------------------- + + u (k) = ua (i, k) + v (k) = va (i, k) + if (.not. hydrostatic) then + w (k) = wa (i, k) + endif + + enddo + + do k = ks, ke + denfac (k) = sqrt (den (ke) / den (k)) + enddo + + ! ----------------------------------------------------------------------- + ! total energy checker + ! ----------------------------------------------------------------------- + + if (consv_checker) then + call mtetw (ks, ke, qvz, qlz, qrz, qiz, qsz, qgz, tz, u, v, w, & + dp, gsize (i), dte (i), 0.0, water (i), rain (i), ice (i), & + snow (i), graupel (i), 0.0, 0.0, dtm, te_beg_d (i, :), tw_beg_d (i, :), & + te_b_beg_d (i), tw_b_beg_d (i), .false., hydrostatic) + endif + + ! ----------------------------------------------------------------------- + ! cloud condensation nuclei (CCN), cloud ice nuclei (CIN) + ! ----------------------------------------------------------------------- + + if (prog_ccn) then + do k = ks, ke + ! boucher and lohmann (1995) + nl = min (1., abs (hs (i)) / (10. * grav)) * & + (10. ** 2.24 * (qnl (i, k) * den (k) * 1.e9) ** 0.257) + & + (1. - min (1., abs (hs (i)) / (10. * grav))) * & + (10. ** 2.06 * (qnl (i, k) * den (k) * 1.e9) ** 0.48) + ni = qni (i, k) + ccn (k) = max (10.0, nl) * 1.e6 + cin (k) = max (10.0, ni) * 1.e6 + ccn (k) = ccn (k) / den (k) + cin (k) = cin (k) / den (k) + enddo + else + ccn0 = (ccn_l * min (1., abs (hs (i)) / (10. * grav)) + & + ccn_o * (1. - min (1., abs (hs (i)) / (10. * grav)))) * 1.e6 + cin0 = 0.0 + do k = ks, ke + ccn (k) = ccn0 / den (k) + cin (k) = cin0 / den (k) + enddo + endif + + ! ----------------------------------------------------------------------- + ! subgrid deviation in horizontal direction + ! default area dependent form: use dx ~ 100 km as the base + ! ----------------------------------------------------------------------- + + t_lnd = dw_land * sqrt (gsize (i) / 1.e5) + t_ocn = dw_ocean * sqrt (gsize (i) / 1.e5) + tmp = min (1., abs (hs (i)) / (10. * grav)) + h_var = t_lnd * tmp + t_ocn * (1. - tmp) + h_var = min (0.20, max (0.01, h_var)) + + ! ----------------------------------------------------------------------- + ! relative humidity thresholds + ! ----------------------------------------------------------------------- + + rh_adj = 1. - h_var - rh_inc + rh_rain = max (0.35, rh_adj - rh_inr) + + ! ----------------------------------------------------------------------- + ! fix negative water species from outside + ! ----------------------------------------------------------------------- + + if (fix_negative) & + call neg_adj (ks, ke, tz, dp, qvz, qlz, qrz, qiz, qsz, qgz, cond) + + condensation (i) = condensation (i) + cond * convt * ntimes + + ! ----------------------------------------------------------------------- + ! fast microphysics loop + ! ----------------------------------------------------------------------- + + if (do_mp_fast) then + + call mp_fast (ks, ke, tz, qvz, qlz, qrz, qiz, qsz, qgz, dtm, dp, den, & + ccn, cin, condensation (i), deposition (i), evaporation (i), & + sublimation (i), convt) + + endif + + ! ----------------------------------------------------------------------- + ! full microphysics loop + ! ----------------------------------------------------------------------- + + if (do_mp_full) then + + call mp_full (ks, ke, ntimes, tz, qvz, qlz, qrz, qiz, qsz, qgz, dp, dz, & + u, v, w, den, denfac, ccn, cin, dts, rh_adj, rh_rain, h_var, dte (i), & + water (i), rain (i), ice (i), snow (i), graupel (i), prefluxw (i, :), & + prefluxr (i, :), prefluxi (i, :), prefluxs (i, :), prefluxg (i, :), & + condensation (i), deposition (i), evaporation (i), sublimation (i), convt) + + endif + + ! ----------------------------------------------------------------------- + ! cloud fraction diagnostic + ! ----------------------------------------------------------------------- + + if (do_qa .and. last_step) then + call cloud_fraction (ks, ke, pz, den, qvz, qlz, qrz, qiz, qsz, qgz, qaz, & + tz, h_var, gsize (i)) + endif + + ! ======================================================================= + ! calculation of particle concentration (pc), effective diameter (ed), + ! optical extinction (oe), radar reflectivity factor (rr), and + ! mass-weighted terminal velocity (tv) + ! ======================================================================= + + pcw (i, :) = 0.0 + edw (i, :) = 0.0 + oew (i, :) = 0.0 + rrw (i, :) = 0.0 + tvw (i, :) = 0.0 + pci (i, :) = 0.0 + edi (i, :) = 0.0 + oei (i, :) = 0.0 + rri (i, :) = 0.0 + tvi (i, :) = 0.0 + pcr (i, :) = 0.0 + edr (i, :) = 0.0 + oer (i, :) = 0.0 + rrr (i, :) = 0.0 + tvr (i, :) = 0.0 + pcs (i, :) = 0.0 + eds (i, :) = 0.0 + oes (i, :) = 0.0 + rrs (i, :) = 0.0 + tvs (i, :) = 0.0 + pcg (i, :) = 0.0 + edg (i, :) = 0.0 + oeg (i, :) = 0.0 + rrg (i, :) = 0.0 + tvg (i, :) = 0.0 + + do k = ks, ke + if (qlz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qlz (k), den (k), blinw, muw, pcaw, pcbw, pcw (i, k), & + edaw, edbw, edw (i, k), oeaw, oebw, oew (i, k), rraw, rrbw, rrw (i, k), & + tvaw, tvbw, tvw (i, k)) + endif + if (qiz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qiz (k), den (k), blini, mui, pcai, pcbi, pci (i, k), & + edai, edbi, edi (i, k), oeai, oebi, oei (i, k), rrai, rrbi, rri (i, k), & + tvai, tvbi, tvi (i, k)) + endif + if (qrz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qrz (k), den (k), blinr, mur, pcar, pcbr, pcr (i, k), & + edar, edbr, edr (i, k), oear, oebr, oer (i, k), rrar, rrbr, rrr (i, k), & + tvar, tvbr, tvr (i, k)) + endif + if (qsz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qsz (k), den (k), blins, mus, pcas, pcbs, pcs (i, k), & + edas, edbs, eds (i, k), oeas, oebs, oes (i, k), rras, rrbs, rrs (i, k), & + tvas, tvbs, tvs (i, k)) + endif + if (do_hail) then + if (qgz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qgz (k), den (k), blinh, muh, pcah, pcbh, pcg (i, k), & + edah, edbh, edg (i, k), oeah, oebh, oeg (i, k), rrah, rrbh, rrg (i, k), & + tvah, tvbh, tvg (i, k)) + endif + else + if (qgz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qgz (k), den (k), bling, mug, pcag, pcbg, pcg (i, k), & + edag, edbg, edg (i, k), oeag, oebg, oeg (i, k), rrag, rrbg, rrg (i, k), & + tvag, tvbg, tvg (i, k)) + endif + endif + enddo + + ! ----------------------------------------------------------------------- + ! momentum transportation during sedimentation + ! update temperature before delp and q update + ! ----------------------------------------------------------------------- + + if (do_sedi_uv) then + do k = ks, ke + c8 = mhc (qvz (k), qlz (k), qrz (k), qiz (k), qsz (k), qgz (k)) * c_air + tzuv (k) = 0.5 * (ua (i, k) ** 2 + va (i, k) ** 2 - (u (k) ** 2 + v (k) ** 2)) / c8 + tz (k) = tz (k) + tzuv (k) + enddo + endif + + if (do_sedi_w) then + do k = ks, ke + c8 = mhc (qvz (k), qlz (k), qrz (k), qiz (k), qsz (k), qgz (k)) * c_air + tzw (k) = 0.5 * (wa (i, k) ** 2 - w (k) ** 2) / c8 + tz (k) = tz (k) + tzw (k) + enddo + endif + + ! ----------------------------------------------------------------------- + ! total energy checker + ! ----------------------------------------------------------------------- + + if (consv_checker) then + call mtetw (ks, ke, qvz, qlz, qrz, qiz, qsz, qgz, tz, u, v, w, & + dp, gsize (i), dte (i), 0.0, water (i), rain (i), ice (i), & + snow (i), graupel (i), 0.0, 0.0, dtm, te_end_d (i, :), tw_end_d (i, :), & + te_b_end_d (i), tw_b_end_d (i), .false., hydrostatic, te_loss (i)) + endif + + do k = ks, ke + + ! ----------------------------------------------------------------------- + ! convert mass mixing ratios back to specific ratios + ! ----------------------------------------------------------------------- + + if (do_inline_mp) then + q_cond = qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k) + con_r8 = one_r8 + qvz (k) + q_cond + else + con_r8 = one_r8 + qvz (k) + endif + + delp (i, k) = dp (k) * con_r8 + con_r8 = one_r8 / con_r8 + qvz (k) = qvz (k) * con_r8 + qlz (k) = qlz (k) * con_r8 + qrz (k) = qrz (k) * con_r8 + qiz (k) = qiz (k) * con_r8 + qsz (k) = qsz (k) * con_r8 + qgz (k) = qgz (k) * con_r8 + + q1 = qv (i, k) + ql (i, k) + qr (i, k) + qi (i, k) + qs (i, k) + qg (i, k) + q2 = qvz (k) + qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k) + adj_vmr (i, k) = ((one_r8 - q1) / (one_r8 - q2)) / (one_r8 + q2 - q1) + + qv (i, k) = qvz (k) + ql (i, k) = qlz (k) + qr (i, k) = qrz (k) + qi (i, k) = qiz (k) + qs (i, k) = qsz (k) + qg (i, k) = qgz (k) + qa (i, k) = qaz (k) + + ! ----------------------------------------------------------------------- + ! calculate some more variables needed outside + ! ----------------------------------------------------------------------- + + q_liq (k) = qlz (k) + qrz (k) + q_sol (k) = qiz (k) + qsz (k) + qgz (k) + q_cond = q_liq (k) + q_sol (k) + con_r8 = one_r8 - (qvz (k) + q_cond) + c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air + +#ifdef USE_COND + q_con (i, k) = q_cond +#endif +#ifdef MOIST_CAPPA + tmp = rdgas * (1. + zvir * qvz (k)) + cappa (i, k) = tmp / (tmp + c8) +#endif + + enddo + + ! ----------------------------------------------------------------------- + ! momentum transportation during sedimentation + ! update temperature after delp and q update + ! ----------------------------------------------------------------------- + + if (do_sedi_uv) then + do k = ks, ke + tz (k) = tz (k) - tzuv (k) + q_liq (k) = qlz (k) + qrz (k) + q_sol (k) = qiz (k) + qsz (k) + qgz (k) + q_cond = q_liq (k) + q_sol (k) + con_r8 = one_r8 - (qvz (k) + q_cond) + c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air + tzuv (k) = (0.5 * (ua (i, k) ** 2 + va (i, k) ** 2) * dp0 (k) - & + 0.5 * (u (k) ** 2 + v (k) ** 2) * delp (i, k)) / c8 / delp (i, k) + tz (k) = tz (k) + tzuv (k) + enddo + do k = ks, ke + ua (i, k) = u (k) + va (i, k) = v (k) + enddo + endif + + if (do_sedi_w) then + do k = ks, ke + tz (k) = tz (k) - tzw (k) + q_liq (k) = qlz (k) + qrz (k) + q_sol (k) = qiz (k) + qsz (k) + qgz (k) + q_cond = q_liq (k) + q_sol (k) + con_r8 = one_r8 - (qvz (k) + q_cond) + c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air + tzw (k) = (0.5 * (wa (i, k) ** 2) * dp0 (k) - & + 0.5 * (w (k) ** 2) * delp (i, k)) / c8 / delp (i, k) + tz (k) = tz (k) + tzw (k) + enddo + do k = ks, ke + wa (i, k) = w (k) + enddo + endif + + ! ----------------------------------------------------------------------- + ! total energy checker + ! ----------------------------------------------------------------------- + + if (consv_checker) then + call mtetw (ks, ke, qv (i, :), ql (i, :), qr (i, :), qi (i, :), & + qs (i, :), qg (i, :), tz, ua (i, :), va (i, :), wa (i, :), & + delp (i, :), gsize (i), dte (i), 0.0, water (i), rain (i), & + ice (i), snow (i), graupel (i), 0.0, 0.0, dtm, te_end_m (i, :), & + tw_end_m (i, :), te_b_end_m (i), tw_b_end_m (i), .true., hydrostatic) + endif + + ! ----------------------------------------------------------------------- + ! calculate total energy loss or gain + ! ----------------------------------------------------------------------- + + if (consv_te) then + if (hydrostatic) then + do k = ks, ke + te (i, k) = te (i, k) + c_air * tz (k) * delp (i, k) + enddo + else + do k = ks, ke + te (i, k) = te (i, k) + mte (qv (i, k), ql (i, k), qr (i, k), qi (i, k), & + qs (i, k), qg (i, k), tz (k), delp (i, k), .true.) * grav + enddo + endif + endif + + ! ----------------------------------------------------------------------- + ! conversion of temperature + ! ----------------------------------------------------------------------- + + if (do_inline_mp) then + do k = ks, ke + q_cond = qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k) + if (cp_heating) then + con_r8 = one_r8 - (qvz (k) + q_cond) + c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air + cp8 = con_r8 * cp_air + qvz (k) * cp_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + delz (i, k) = delz (i, k) / pt (i, k) + pt (i, k) = pt (i, k) + (tz (k) * ((1. + zvir * qvz (k)) * (1. - q_cond)) - pt (i, k)) * c8 / cp8 + delz (i, k) = delz (i, k) * pt (i, k) + else + pt (i, k) = tz (k) * ((1. + zvir * qvz (k)) * (1. - q_cond)) + endif + enddo + else + do k = ks, ke + q_liq (k) = qlz (k) + qrz (k) + q_sol (k) = qiz (k) + qsz (k) + qgz (k) + q_cond = q_liq (k) + q_sol (k) + con_r8 = one_r8 - (qvz (k) + q_cond) + c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air + pt (i, k) = pt (i, k) + (tz (k) - pt (i, k)) * c8 / cp_air + enddo + endif + + ! ----------------------------------------------------------------------- + ! total energy checker + ! ----------------------------------------------------------------------- + + if (consv_checker) then + if (abs (sum (te_end_d (i, :)) + te_b_end_d (i) - sum (te_beg_d (i, :)) - te_b_beg_d (i)) / & + (sum (te_beg_d (i, :)) + te_b_beg_d (i)) .gt. te_err) then + print*, "GFDL-MP-DRY TE: ", & + !(sum (te_beg_d (i, :)) + te_b_beg_d (i)) / (gsize (i) ** 2), & + !(sum (te_end_d (i, :)) + te_b_end_d (i)) / (gsize (i) ** 2), & + (sum (te_end_d (i, :)) + te_b_end_d (i) - sum (te_beg_d (i, :)) - te_b_beg_d (i)) / & + (sum (te_beg_d (i, :)) + te_b_beg_d (i)) + endif + if (abs (sum (tw_end_d (i, :)) + tw_b_end_d (i) - sum (tw_beg_d (i, :)) - tw_b_beg_d (i)) / & + (sum (tw_beg_d (i, :)) + tw_b_beg_d (i)) .gt. tw_err) then + print*, "GFDL-MP-DRY TW: ", & + !(sum (tw_beg_d (i, :)) + tw_b_beg_d (i)) / (gsize (i) ** 2), & + !(sum (tw_end_d (i, :)) + tw_b_end_d (i)) / (gsize (i) ** 2), & + (sum (tw_end_d (i, :)) + tw_b_end_d (i) - sum (tw_beg_d (i, :)) - tw_b_beg_d (i)) / & + (sum (tw_beg_d (i, :)) + tw_b_beg_d (i)) + endif + !print*, "GFDL MP TE DRY LOSS (%) : ", te_loss (i) / (sum (te_beg_d (i, :)) + te_b_beg_d (i)) * 100.0 + if (abs (sum (te_end_m (i, :)) + te_b_end_m (i) - sum (te_beg_m (i, :)) - te_b_beg_m (i)) / & + (sum (te_beg_m (i, :)) + te_b_beg_m (i)) .gt. te_err) then + print*, "GFDL-MP-WET TE: ", & + !(sum (te_beg_m (i, :)) + te_b_beg_m (i)) / (gsize (i) ** 2), & + !(sum (te_end_m (i, :)) + te_b_end_m (i)) / (gsize (i) ** 2), & + (sum (te_end_m (i, :)) + te_b_end_m (i) - sum (te_beg_m (i, :)) - te_b_beg_m (i)) / & + (sum (te_beg_m (i, :)) + te_b_beg_m (i)) + endif + if (abs (sum (tw_end_m (i, :)) + tw_b_end_m (i) - sum (tw_beg_m (i, :)) - tw_b_beg_m (i)) / & + (sum (tw_beg_m (i, :)) + tw_b_beg_m (i)) .gt. tw_err) then + print*, "GFDL-MP-WET TW: ", & + !(sum (tw_beg_m (i, :)) + tw_b_beg_m (i)) / (gsize (i) ** 2), & + !(sum (tw_end_m (i, :)) + tw_b_end_m (i)) / (gsize (i) ** 2), & + (sum (tw_end_m (i, :)) + tw_b_end_m (i) - sum (tw_beg_m (i, :)) - tw_b_beg_m (i)) / & + (sum (tw_beg_m (i, :)) + tw_b_beg_m (i)) + endif + !print*, "GFDL MP TE WET LOSS (%) : ", te_loss_0 (i) / (sum (te_beg_m (i, :)) + te_b_beg_m (i)) * 100.0 + endif + + enddo ! i loop + +end subroutine mpdrv + +! ======================================================================= +! fix negative water species +! ======================================================================= + +subroutine neg_adj (ks, ke, tz, dp, qv, ql, qr, qi, qs, qg, cond) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in), dimension (ks:ke) :: dp + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + + real, intent (out) :: cond + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: dq, sink + + real, dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), dimension (ks:ke) :: cvm, te8 + + ! ----------------------------------------------------------------------- + ! initialization + ! ----------------------------------------------------------------------- + + cond = 0 + + ! ----------------------------------------------------------------------- + ! calculate moist heat capacity and latent heat coefficients + ! ----------------------------------------------------------------------- + + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & + lcpk, icpk, tcpk, tcp3) + + do k = ks, ke + + ! ----------------------------------------------------------------------- + ! fix negative solid-phase hydrometeors + ! ----------------------------------------------------------------------- + + ! if cloud ice < 0, borrow from snow + if (qi (k) .lt. 0.) then + sink = min (- qi (k), max (0., qs (k))) + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., sink, - sink, 0.) + endif + + ! if snow < 0, borrow from graupel + if (qs (k) .lt. 0.) then + sink = min (- qs (k), max (0., qg (k))) + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., 0., sink, - sink) + endif + + ! if graupel < 0, borrow from rain + if (qg (k) .lt. 0.) then + sink = min (- qg (k), max (0., qr (k))) + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., - sink, 0., 0., sink, te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + endif + + ! ----------------------------------------------------------------------- + ! fix negative liquid-phase hydrometeors + ! ----------------------------------------------------------------------- + + ! if rain < 0, borrow from cloud water + if (qr (k) .lt. 0.) then + sink = min (- qr (k), max (0., ql (k))) + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, sink, 0., 0., 0.) + endif + + ! if cloud water < 0, borrow from water vapor + if (ql (k) .lt. 0.) then + sink = min (- ql (k), max (0., qv (k))) + cond = cond + sink * dp (k) + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + - sink, sink, 0., 0., 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + endif + + enddo + + ! ----------------------------------------------------------------------- + ! fix negative water vapor + ! ----------------------------------------------------------------------- + + ! if water vapor < 0, borrow water vapor from below + do k = ks, ke - 1 + if (qv (k) .lt. 0.) then + qv (k + 1) = qv (k + 1) + qv (k) * dp (k) / dp (k + 1) + qv (k) = 0. + endif + enddo + + ! if water vapor < 0, borrow water vapor from above + if (qv (ke) .lt. 0. .and. qv (ke - 1) .gt. 0.) then + dq = min (- qv (ke) * dp (ke), qv (ke - 1) * dp (ke - 1)) + qv (ke - 1) = qv (ke - 1) - dq / dp (ke - 1) + qv (ke) = qv (ke) + dq / dp (ke) + endif + +end subroutine neg_adj + +! ======================================================================= +! full microphysics loop +! ======================================================================= + +subroutine mp_full (ks, ke, ntimes, tz, qv, ql, qr, qi, qs, qg, dp, dz, u, v, w, & + den, denfac, ccn, cin, dts, rh_adj, rh_rain, h_var, dte, water, rain, ice, & + snow, graupel, prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, & + condensation, deposition, evaporation, sublimation, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke, ntimes + + real, intent (in) :: dts, rh_adj, rh_rain, h_var, convt + + real, intent (in), dimension (ks:ke) :: dp, dz, den, denfac + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, u, v, w, ccn, cin + real, intent (inout), dimension (ks:ke) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: water, rain, ice, snow, graupel + real, intent (inout) :: condensation, deposition + real, intent (inout) :: evaporation, sublimation + + real (kind = r8), intent (inout) :: dte + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: n + + real :: w1, r1, i1, s1, g1, cond, dep, reevap, sub + + real, dimension (ks:ke) :: vtw, vtr, vti, vts, vtg, pfw, pfr, pfi, pfs, pfg + + do n = 1, ntimes + + ! ----------------------------------------------------------------------- + ! sedimentation of cloud ice, snow, graupel or hail, and rain + ! ----------------------------------------------------------------------- + + call sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, & + dz, dp, vtw, vtr, vti, vts, vtg, w1, r1, i1, s1, g1, pfw, pfr, pfi, pfs, pfg, & + u, v, w, den, denfac, dte) + + water = water + w1 * convt + rain = rain + r1 * convt + ice = ice + i1 * convt + snow = snow + s1 * convt + graupel = graupel + g1 * convt + + prefluxw = prefluxw + pfw * convt + prefluxr = prefluxr + pfr * convt + prefluxi = prefluxi + pfi * convt + prefluxs = prefluxs + pfs * convt + prefluxg = prefluxg + pfg * convt + + ! ----------------------------------------------------------------------- + ! warm rain cloud microphysics + ! ----------------------------------------------------------------------- + + call warm_rain (dts, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, & + den, denfac, vtw, vtr, ccn, rh_rain, h_var, reevap) + + evaporation = evaporation + reevap * convt + + ! ----------------------------------------------------------------------- + ! ice cloud microphysics + ! ----------------------------------------------------------------------- + + call ice_cloud (ks, ke, tz, qv, ql, qr, qi, qs, qg, den, & + denfac, vtw, vtr, vti, vts, vtg, dts, h_var) + + ! ----------------------------------------------------------------------- + ! temperature sentive high vertical resolution processes + ! ----------------------------------------------------------------------- + + call subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, & + qr, qi, qs, qg, dp, ccn, cin, cond, dep, reevap, sub) + + condensation = condensation + cond * convt + deposition = deposition + dep * convt + evaporation = evaporation + reevap * convt + sublimation = sublimation + sub * convt + + enddo + +end subroutine mp_full + +! ======================================================================= +! fast microphysics loop +! ======================================================================= + +subroutine mp_fast (ks, ke, tz, qv, ql, qr, qi, qs, qg, dtm, dp, den, & + ccn, cin, condensation, deposition, evaporation, sublimation, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dtm, convt + + real, intent (in), dimension (ks:ke) :: dp, den + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn, cin + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: condensation, deposition + real, intent (inout) :: evaporation, sublimation + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real :: cond, dep, reevap, sub + + real, dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), dimension (ks:ke) :: cvm, te8 + + ! ----------------------------------------------------------------------- + ! initialization + ! ----------------------------------------------------------------------- + + cond = 0 + dep = 0 + reevap = 0 + sub = 0 + + ! ----------------------------------------------------------------------- + ! calculate heat capacities and latent heat coefficients + ! ----------------------------------------------------------------------- + + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & + lcpk, icpk, tcpk, tcp3) + + if (.not. do_warm_rain_mp) then + + ! ----------------------------------------------------------------------- + ! cloud ice melting to form cloud water and rain + ! ----------------------------------------------------------------------- + + call pimlt (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! enforce complete freezing below t_wfr + ! ----------------------------------------------------------------------- + + call pcomp (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3) + + endif + + ! ----------------------------------------------------------------------- + ! cloud water condensation and evaporation + ! ----------------------------------------------------------------------- + + call pcond_pevap (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, cond, reevap) + + condensation = condensation + cond * convt + evaporation = evaporation + reevap * convt + + if (.not. do_warm_rain_mp) then + + ! ----------------------------------------------------------------------- + ! cloud water freezing to form cloud ice and snow + ! ----------------------------------------------------------------------- + + call pifr (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! Wegener Bergeron Findeisen process + ! ----------------------------------------------------------------------- + + call pwbf (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! Bigg freezing mechanism + ! ----------------------------------------------------------------------- + + call pbigg (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, ccn, & + lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! rain freezing to form graupel + ! ----------------------------------------------------------------------- + + call pgfr_simp (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! snow melting to form cloud water and rain + ! ----------------------------------------------------------------------- + + call psmlt_simp (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3) + + endif + + ! ----------------------------------------------------------------------- + ! cloud water to rain autoconversion + ! ----------------------------------------------------------------------- + + call praut_simp (ks, ke, dtm, tz, qv, ql, qr, qi, qs, qg) + + if (.not. do_warm_rain_mp) then + + ! ----------------------------------------------------------------------- + ! cloud ice deposition and sublimation + ! ----------------------------------------------------------------------- + + call pidep_pisub (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, cin, dep, sub) + + deposition = deposition + dep * convt + sublimation = sublimation + sub * convt + + ! ----------------------------------------------------------------------- + ! cloud ice to snow autoconversion + ! ----------------------------------------------------------------------- + + call psaut_simp (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, den) + + endif + +end subroutine mp_fast + +! ======================================================================= +! sedimentation of cloud ice, snow, graupel or hail, and rain +! ======================================================================= + +subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vtw, vtr, vti, vts, vtg, w1, r1, i1, s1, g1, pfw, pfr, pfi, pfs, pfg, & + u, v, w, den, denfac, dte) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke) :: dp, dz, den, denfac + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, u, v, w + + real, intent (out) :: w1, r1, i1, s1, g1 + + real, intent (out), dimension (ks:ke) :: vtw, vtr, vti, vts, vtg, pfw, pfr, pfi, pfs, pfg + + real (kind = r8), intent (inout) :: dte + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real, dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), dimension (ks:ke) :: te8, cvm + + w1 = 0. + r1 = 0. + i1 = 0. + s1 = 0. + g1 = 0. + + vtw = 0. + vtr = 0. + vti = 0. + vts = 0. + vtg = 0. + + pfw = 0. + pfr = 0. + pfi = 0. + pfs = 0. + pfg = 0. + + ! ----------------------------------------------------------------------- + ! calculate heat capacities and latent heat coefficients + ! ----------------------------------------------------------------------- + + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & + lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! terminal fall and melting of falling cloud ice into rain + ! ----------------------------------------------------------------------- + + if (do_psd_ice_fall) then + call term_rsg (ks, ke, qi, den, denfac, vi_fac, blini, mui, tvai, tvbi, vi_max, const_vi, vti) + else + call term_ice (ks, ke, tz, qi, den, vi_fac, vi_max, const_vi, vti) + endif + + if (do_sedi_melt) then + call sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vti, r1, tau_imlt, icpk, "qi") + endif + + call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vti, i1, pfi, u, v, w, dte, "qi") + + pfi (ks) = max (0.0, pfi (ks)) + do k = ke, ks + 1, -1 + pfi (k) = max (0.0, pfi (k) - pfi (k - 1)) + enddo + + ! ----------------------------------------------------------------------- + ! terminal fall and melting of falling snow into rain + ! ----------------------------------------------------------------------- + + call term_rsg (ks, ke, qs, den, denfac, vs_fac, blins, mus, tvas, tvbs, vs_max, const_vs, vts) + + if (do_sedi_melt) then + call sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vts, r1, tau_smlt, icpk, "qs") + endif + + call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vts, s1, pfs, u, v, w, dte, "qs") + + pfs (ks) = max (0.0, pfs (ks)) + do k = ke, ks + 1, -1 + pfs (k) = max (0.0, pfs (k) - pfs (k - 1)) + enddo + + ! ----------------------------------------------------------------------- + ! terminal fall and melting of falling graupel into rain + ! ----------------------------------------------------------------------- + + if (do_hail) then + call term_rsg (ks, ke, qg, den, denfac, vg_fac, blinh, muh, tvah, tvbh, vg_max, const_vg, vtg) + else + call term_rsg (ks, ke, qg, den, denfac, vg_fac, bling, mug, tvag, tvbg, vg_max, const_vg, vtg) + endif + + if (do_sedi_melt) then + call sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vtg, r1, tau_gmlt, icpk, "qg") + endif + + call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vtg, g1, pfg, u, v, w, dte, "qg") + + pfg (ks) = max (0.0, pfg (ks)) + do k = ke, ks + 1, -1 + pfg (k) = max (0.0, pfg (k) - pfg (k - 1)) + enddo + + ! ----------------------------------------------------------------------- + ! terminal fall of cloud water + ! ----------------------------------------------------------------------- + + if (do_psd_water_fall) then + + call term_rsg (ks, ke, ql, den, denfac, vw_fac, blinw, muw, tvaw, tvbw, vw_max, const_vw, vtw) + + call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vtw, w1, pfw, u, v, w, dte, "ql") + + pfw (ks) = max (0.0, pfw (ks)) + do k = ke, ks + 1, -1 + pfw (k) = max (0.0, pfw (k) - pfw (k - 1)) + enddo + + endif + + ! ----------------------------------------------------------------------- + ! terminal fall of rain + ! ----------------------------------------------------------------------- + + call term_rsg (ks, ke, qr, den, denfac, vr_fac, blinr, mur, tvar, tvbr, vr_max, const_vr, vtr) + + call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vtr, r1, pfr, u, v, w, dte, "qr") + + pfr (ks) = max (0.0, pfr (ks)) + do k = ke, ks + 1, -1 + pfr (k) = max (0.0, pfr (k) - pfr (k - 1)) + enddo + +end subroutine sedimentation + +! ======================================================================= +! terminal velocity for cloud ice +! ======================================================================= + +subroutine term_ice (ks, ke, tz, q, den, v_fac, v_max, const_v, vt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + logical, intent (in) :: const_v + + real, intent (in) :: v_fac, v_max + + real, intent (in), dimension (ks:ke) :: q, den + + real (kind = r8), intent (in), dimension (ks:ke) :: tz + + real, intent (out), dimension (ks:ke) :: vt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: qden + + real, parameter :: aa = - 4.14122e-5 + real, parameter :: bb = - 0.00538922 + real, parameter :: cc = - 0.0516344 + real, parameter :: dd = 0.00216078 + real, parameter :: ee = 1.9714 + + real, dimension (ks:ke) :: tc + + if (const_v) then + vt (:) = v_fac + else + do k = ks, ke + qden = q (k) * den (k) + if (q (k) .lt. qfmin) then + vt (k) = 0.0 + else + tc (k) = tz (k) - tice + if (ifflag .eq. 1) then + vt (k) = (3. + log10 (qden)) * (tc (k) * (aa * tc (k) + bb) + cc) + & + dd * tc (k) + ee + vt (k) = 0.01 * v_fac * exp (vt (k) * log (10.)) + endif + if (ifflag .eq. 2) & + vt (k) = v_fac * 3.29 * exp (0.16 * log (qden)) + vt (k) = min (v_max, max (0.0, vt (k))) + endif + enddo + endif + +end subroutine term_ice + +! ======================================================================= +! terminal velocity for rain, snow, and graupel, Lin et al. (1983) +! ======================================================================= + +subroutine term_rsg (ks, ke, q, den, denfac, v_fac, blin, mu, tva, tvb, v_max, const_v, vt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + logical, intent (in) :: const_v + + real, intent (in) :: v_fac, blin, v_max, mu + + real (kind = r8), intent (in) :: tva, tvb + + real, intent (in), dimension (ks:ke) :: q, den, denfac + + real, intent (out), dimension (ks:ke) :: vt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + if (const_v) then + vt (:) = v_fac + else + do k = ks, ke + if (q (k) .lt. qfmin) then + vt (k) = 0.0 + else + call cal_pc_ed_oe_rr_tv (q (k), den (k), blin, mu, & + tva = tva, tvb = tvb, tv = vt (k)) + vt (k) = v_fac * vt (k) * denfac (k) + vt (k) = min (v_max, max (0.0, vt (k))) + endif + enddo + endif + +end subroutine term_rsg + +! ======================================================================= +! melting during sedimentation +! ======================================================================= + +subroutine sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vt, r1, tau_mlt, icpk, qflag) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, tau_mlt + + real, intent (in), dimension (ks:ke) :: vt, dp, dz, icpk + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + + real, intent (inout) :: r1 + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + character (len = 2), intent (in) :: qflag + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k, m + + real :: dtime, sink, zs + + real, dimension (ks:ke) :: q + + real, dimension (ks:ke + 1) :: ze, zt + + real (kind = r8), dimension (ks:ke) :: cvm + + call zezt (ks, ke, dts, zs, dz, vt, ze, zt) + + select case (qflag) + case ("qi") + q = qi + case ("qs") + q = qs + case ("qg") + q = qg + case default + print *, "gfdl_mp: qflag error!" + end select + + ! ----------------------------------------------------------------------- + ! melting to rain + ! ----------------------------------------------------------------------- + + do k = ke - 1, ks, - 1 + if (vt (k) .lt. 1.e-10) cycle + if (q (k) .gt. qcmin) then + do m = k + 1, ke + if (zt (k + 1) .ge. ze (m)) exit + if (zt (k) .lt. ze (m + 1) .and. tz (m) .gt. tice) then + cvm (k) = mhc (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k)) + cvm (m) = mhc (qv (m), ql (m), qr (m), qi (m), qs (m), qg (m)) + dtime = min (dts, (ze (m) - ze (m + 1)) / vt (k)) + dtime = min (1.0, dtime / tau_mlt) + sink = min (q (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) + q (k) = q (k) - sink * dp (m) / dp (k) + if (zt (k) .lt. zs) then + r1 = r1 + sink * dp (m) + else + qr (m) = qr (m) + sink + endif + select case (qflag) + case ("qi") + qi (k) = q (k) + case ("qs") + qs (k) = q (k) + case ("qg") + qg (k) = q (k) + case default + print *, "gfdl_mp: qflag error!" + end select + tz (k) = (tz (k) * cvm (k) - li00 * sink * dp (m) / dp (k)) / & + mhc (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k)) + tz (m) = (tz (m) * cvm (m)) / & + mhc (qv (m), ql (m), qr (m), qi (m), qs (m), qg (m)) + endif + if (q (k) .lt. qcmin) exit + enddo + endif + enddo + +end subroutine sedi_melt + +! ======================================================================= +! melting during sedimentation +! ======================================================================= + +subroutine terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vt, x1, m1, u, v, w, dte, qflag) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke) :: vt, dp, dz + + character (len = 2), intent (in) :: qflag + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, u, v, w + + real, intent (inout) :: x1 + + real (kind = r8), intent (inout) :: dte + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (out), dimension (ks:ke) :: m1 + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + logical :: no_fall + + real :: zs + + real, dimension (ks:ke) :: dm, q + + real, dimension (ks:ke + 1) :: ze, zt + + real (kind = r8), dimension (ks:ke) :: te1, te2 + + m1 = 0.0 + + call zezt (ks, ke, dts, zs, dz, vt, ze, zt) + + select case (qflag) + case ("ql") + q = ql + case ("qr") + q = qr + case ("qi") + q = qi + case ("qs") + q = qs + case ("qg") + q = qg + case default + print *, "gfdl_mp: qflag error!" + end select + + call check_column (ks, ke, q, no_fall) + + if (no_fall) return + + ! ----------------------------------------------------------------------- + ! momentum transportation during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_w) then + do k = ks, ke + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + ! ----------------------------------------------------------------------- + ! energy change during sedimentation + ! ----------------------------------------------------------------------- + + do k = ks, ke + te1 (k) = mte (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), tz (k), dp (k), .false.) + enddo + + ! ----------------------------------------------------------------------- + ! sedimentation + ! ----------------------------------------------------------------------- + + select case (qflag) + case ("ql") + q = ql + case ("qr") + q = qr + case ("qi") + q = qi + case ("qs") + q = qs + case ("qg") + q = qg + case default + print *, "gfdl_mp: qflag error!" + end select + + if (sedflag .eq. 1) & + call implicit_fall (dts, ks, ke, ze, vt, dp, q, x1, m1) + if (sedflag .eq. 2) & + call explicit_fall (dts, ks, ke, ze, vt, dp, q, x1, m1) + if (sedflag .eq. 3) & + call lagrangian_fall (ks, ke, zs, ze, zt, dp, q, x1, m1) + if (sedflag .eq. 4) & + call implicit_lagrangian_fall (dts, ks, ke, zs, ze, zt, vt, dp, q, & + x1, m1, sed_fac) + + select case (qflag) + case ("ql") + ql = q + case ("qr") + qr = q + case ("qi") + qi = q + case ("qs") + qs = q + case ("qg") + qg = q + case default + print *, "gfdl_mp: qflag error!" + end select + + ! ----------------------------------------------------------------------- + ! energy change during sedimentation + ! ----------------------------------------------------------------------- + + do k = ks, ke + te2 (k) = mte (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), tz (k), dp (k), .false.) + enddo + dte = dte + sum (te1) - sum (te2) + + ! ----------------------------------------------------------------------- + ! momentum transportation during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_uv) then + call sedi_uv (ks, ke, m1, dp, u, v) + endif + + if (do_sedi_w) then + call sedi_w (ks, ke, m1, w, vt, dm) + endif + + ! ----------------------------------------------------------------------- + ! energy change during sedimentation heating + ! ----------------------------------------------------------------------- + + do k = ks, ke + te1 (k) = mte (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), tz (k), dp (k), .false.) + enddo + + ! ----------------------------------------------------------------------- + ! heat exchanges during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_heat) then + call sedi_heat (ks, ke, dp, m1, dz, tz, qv, ql, qr, qi, qs, qg, c_ice) + endif + + ! ----------------------------------------------------------------------- + ! energy change during sedimentation heating + ! ----------------------------------------------------------------------- + + do k = ks, ke + te2 (k) = mte (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), tz (k), dp (k), .false.) + enddo + dte = dte + sum (te1) - sum (te2) + +end subroutine terminal_fall + +! ======================================================================= +! calculate ze zt for sedimentation +! ======================================================================= + +subroutine zezt (ks, ke, dts, zs, dz, vt, ze, zt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke) :: dz, vt + + real, intent (out) :: zs + + real, intent (out), dimension (ks:ke + 1) :: ze, zt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: dt5 + + dt5 = 0.5 * dts + zs = 0.0 + ze (ke + 1) = zs + do k = ke, ks, - 1 + ze (k) = ze (k + 1) - dz (k) + enddo + zt (ks) = ze (ks) + do k = ks + 1, ke + zt (k) = ze (k) - dt5 * (vt (k - 1) + vt (k)) + enddo + zt (ke + 1) = zs - dts * vt (ke) + do k = ks, ke + if (zt (k + 1) .ge. zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + +end subroutine zezt + +! ======================================================================= +! check if water species is large enough to fall +! ======================================================================= + +subroutine check_column (ks, ke, q, no_fall) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: q (ks:ke) + + logical, intent (out) :: no_fall + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + no_fall = .true. + + do k = ks, ke + if (q (k) .gt. qfmin) then + no_fall = .false. + exit + endif + enddo + +end subroutine check_column + +! ======================================================================= +! warm rain cloud microphysics +! ======================================================================= + +subroutine warm_rain (dts, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, & + den, denfac, vtw, vtr, ccn, rh_rain, h_var, reevap) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, rh_rain, h_var + + real, intent (in), dimension (ks:ke) :: dp, dz, den, denfac, vtw, vtr + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (out) :: reevap + + ! ----------------------------------------------------------------------- + ! initialization + ! ----------------------------------------------------------------------- + + reevap = 0 + + ! ----------------------------------------------------------------------- + ! rain evaporation to form water vapor + ! ----------------------------------------------------------------------- + + call prevp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var, dp, reevap) + + ! ----------------------------------------------------------------------- + ! rain accretion with cloud water + ! ----------------------------------------------------------------------- + + call pracw (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, vtw, vtr) + + ! ----------------------------------------------------------------------- + ! cloud water to rain autoconversion + ! ----------------------------------------------------------------------- + + call praut (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, ccn, h_var) + +end subroutine warm_rain + +! ======================================================================= +! rain evaporation to form water vapor, Lin et al. (1983) +! ======================================================================= + +subroutine prevp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var, dp, reevap) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, rh_rain, h_var + + real, intent (in), dimension (ks:ke) :: den, denfac, dp + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout), dimension (ks:ke) :: qv, qr, ql, qi, qs, qg + + real, intent (out) :: reevap + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: dqv, qsat, dqdt, tmp, t2, qden, q_plus, q_minus, sink + real :: qpz, dq, dqh, tin, fac_revp, rh_tem + + real, dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), dimension (ks:ke) :: cvm, te8 + + ! ----------------------------------------------------------------------- + ! initialization + ! ----------------------------------------------------------------------- + + reevap = 0 + + ! ----------------------------------------------------------------------- + ! time-scale factor + ! ----------------------------------------------------------------------- + + fac_revp = 1. + if (tau_revp .gt. 1.e-6) then + fac_revp = 1. - exp (- dts / tau_revp) + endif + + ! ----------------------------------------------------------------------- + ! calculate heat capacities and latent heat coefficients + ! ----------------------------------------------------------------------- + + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & + lcpk, icpk, tcpk, tcp3) + + do k = ks, ke + + tin = (tz (k) * cvm (k) - lv00 * ql (k)) / mhc (qv (k) + ql (k), qr (k), q_sol (k)) + + ! ----------------------------------------------------------------------- + ! calculate supersaturation and subgrid variability of water + ! ----------------------------------------------------------------------- + + qpz = qv (k) + ql (k) + qsat = wqs (tin, den (k), dqdt) + dqv = qsat - qv (k) + + dqh = max (ql (k), h_var * max (qpz, qcmin)) + dqh = min (dqh, 0.2 * qpz) + q_minus = qpz - dqh + q_plus = qpz + dqh + + ! ----------------------------------------------------------------------- + ! rain evaporation + ! ----------------------------------------------------------------------- + + rh_tem = qpz / qsat + + if (tz (k) .gt. t_wfr .and. qr (k) .gt. qcmin .and. dqv .gt. 0.0 .and. qsat .gt. q_minus) then + + if (qsat .gt. q_plus) then + dq = qsat - qpz + else + dq = 0.25 * (qsat - q_minus) ** 2 / dqh + endif + qden = qr (k) * den (k) + t2 = tin * tin + sink = psub (t2, dq, qden, qsat, crevp, den (k), denfac (k), blinr, mur, lcpk (k), cvm (k)) + sink = min (qr (k), dts * fac_revp * sink, dqv / (1. + lcpk (k) * dqdt)) + if (use_rhc_revap .and. rh_tem .ge. rhc_revap) then + sink = 0.0 + endif + + ! ----------------------------------------------------------------------- + ! alternative minimum evaporation in dry environmental air + ! ----------------------------------------------------------------------- + ! tmp = min (qr (k), dim (rh_rain * qsat, qv (k)) / (1. + lcpk (k) * dqdt)) + ! sink = max (sink, tmp) + + reevap = reevap + sink * dp (k) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + sink, 0., - sink, 0., 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo ! k loop + +end subroutine prevp + +! ======================================================================= +! rain accretion with cloud water, Lin et al. (1983) +! ======================================================================= + +subroutine pracw (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, vtw, vtr) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout), dimension (ks:ke) :: qv, qr, ql, qi, qs, qg + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: qden, sink + + do k = ks, ke + + if (tz (k) .gt. t_wfr .and. qr (k) .gt. qcmin .and. ql (k) .gt. qcmin) then + + qden = qr (k) * den (k) + if (do_new_acc_water) then + sink = dts * acr3d (vtr (k), vtw (k), ql (k), qr (k), cracw, acco (:, 5), & + acc (9), acc (10), den (k)) + else + sink = dts * acr2d (qden, cracw, denfac (k), blinr, mur) + sink = sink / (1. + sink) * ql (k) + endif + + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, sink, 0., 0., 0.) + + endif + + enddo + +end subroutine pracw + +! ======================================================================= +! cloud water to rain autoconversion, Hong et al. (2004) +! ======================================================================= + +subroutine praut (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, ccn, h_var) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, h_var + + real, intent (in), dimension (ks:ke) :: den + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real, parameter :: so3 = 7.0 / 3.0 + real, parameter :: so1 = - 1.0 / 3.0 + + integer :: k + + real :: sink, dq, qc + + real, dimension (ks:ke) :: dl, c_praut + + if (irain_f .eq. 0) then + + call linear_prof (ke - ks + 1, ql (ks), dl (ks), z_slope_liq, h_var) + + do k = ks, ke + + if (tz (k) .gt. t_wfr .and. ql (k) .gt. qcmin) then + + if (do_psd_water_num) then + call cal_pc_ed_oe_rr_tv (ql (k), den (k), blinw, muw, & + pca = pcaw, pcb = pcbw, pc = ccn (k)) + ccn (k) = ccn (k) / den (k) + endif + + qc = fac_rc * ccn (k) + dl (k) = min (max (qcmin, dl (k)), 0.5 * ql (k)) + dq = 0.5 * (ql (k) + dl (k) - qc) + + if (dq .gt. 0.) then + + c_praut (k) = cpaut * exp (so1 * log (ccn (k) * rhow)) + sink = min (1., dq / dl (k)) * dts * c_praut (k) * den (k) * & + exp (so3 * log (ql (k))) + sink = min (ql (k), sink) + + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, sink, 0., 0., 0.) + + endif + + endif + + enddo + + endif + + if (irain_f .eq. 1) then + + do k = ks, ke + + if (tz (k) .gt. t_wfr .and. ql (k) .gt. qcmin) then + + if (do_psd_water_num) then + call cal_pc_ed_oe_rr_tv (ql (k), den (k), blinw, muw, & + pca = pcaw, pcb = pcbw, pc = ccn (k)) + ccn (k) = ccn (k) / den (k) + endif + + qc = fac_rc * ccn (k) + dq = ql (k) - qc + + if (dq .gt. 0.) then + + c_praut (k) = cpaut * exp (so1 * log (ccn (k) * rhow)) + sink = min (dq, dts * c_praut (k) * den (k) * exp (so3 * log (ql (k)))) + sink = min (ql (k), sink) + + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, sink, 0., 0., 0.) + + endif + + endif + + enddo + + endif + +end subroutine praut + +! ======================================================================= +! ice cloud microphysics +! ======================================================================= + +subroutine ice_cloud (ks, ke, tz, qv, ql, qr, qi, qs, qg, den, & + denfac, vtw, vtr, vti, vts, vtg, dts, h_var) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, h_var + + real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vti, vts, vtg + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real, dimension (ks:ke) :: di, q_liq, q_sol, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), dimension (ks:ke) :: cvm, te8 + + ! ----------------------------------------------------------------------- + ! calculate heat capacities and latent heat coefficients + ! ----------------------------------------------------------------------- + + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & + lcpk, icpk, tcpk, tcp3) + + if (.not. do_warm_rain_mp) then + + ! ----------------------------------------------------------------------- + ! cloud ice melting to form cloud water and rain + ! ----------------------------------------------------------------------- + + call pimlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! cloud water freezing to form cloud ice and snow + ! ----------------------------------------------------------------------- + + call pifr (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! vertical subgrid variability + ! ----------------------------------------------------------------------- + + call linear_prof (ke - ks + 1, qi, di, z_slope_ice, h_var) + + ! ----------------------------------------------------------------------- + ! snow melting (includes snow accretion with cloud water and rain) to form cloud water and rain + ! ----------------------------------------------------------------------- + + call psmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & + vtw, vtr, vts, lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! graupel melting (includes graupel accretion with cloud water and rain) to form rain + ! ----------------------------------------------------------------------- + + call pgmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & + vtw, vtr, vtg, lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! snow accretion with cloud ice + ! ----------------------------------------------------------------------- + + call psaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vts) + + ! ----------------------------------------------------------------------- + ! cloud ice to snow autoconversion + ! ----------------------------------------------------------------------- + + call psaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, di) + + ! ----------------------------------------------------------------------- + ! graupel accretion with cloud ice + ! ----------------------------------------------------------------------- + + call pgaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vtg) + + ! ----------------------------------------------------------------------- + ! snow accretion with rain and rain freezing to form graupel + ! ----------------------------------------------------------------------- + + call psacr_pgfr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & + vtr, vts, lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! graupel accretion with snow + ! ----------------------------------------------------------------------- + + call pgacs (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, vts, vtg) + + ! ----------------------------------------------------------------------- + ! snow to graupel autoconversion + ! ----------------------------------------------------------------------- + + call pgaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den) + + ! ----------------------------------------------------------------------- + ! graupel accretion with cloud water and rain + ! ----------------------------------------------------------------------- + + call pgacw_pgacr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & + vtr, vtg, lcpk, icpk, tcpk, tcp3) + + endif ! do_warm_rain_mp + +end subroutine ice_cloud + +! ======================================================================= +! cloud ice melting to form cloud water and rain, Lin et al. (1983) +! ======================================================================= + +subroutine pimlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, tmp, sink, fac_imlt + + fac_imlt = 1. - exp (- dts / tau_imlt) + + do k = ks, ke + + tc = tz (k) - tice_mlt + + if (tc .gt. 0 .and. qi (k) .gt. qcmin) then + + sink = fac_imlt * tc / icpk (k) + sink = min (qi (k), sink) + tmp = min (sink, dim (ql_mlt, ql (k))) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., tmp, sink - tmp, - sink, 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pimlt + +! ======================================================================= +! cloud water freezing to form cloud ice and snow, Lin et al. (1983) +! ======================================================================= + +subroutine pifr (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in), dimension (ks:ke) :: den + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, tmp, sink, qim + + do k = ks, ke + + tc = t_wfr - tz (k) + + if (tc .gt. 0. .and. ql (k) .gt. qcmin) then + + sink = ql (k) * tc / dt_fr + sink = min (ql (k), sink, tc / icpk (k)) + qim = qi0_crt / den (k) + tmp = min (sink, dim (qim, qi (k))) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, 0., tmp, sink - tmp, 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pifr + +! ======================================================================= +! snow melting (includes snow accretion with cloud water and rain) to form cloud water and rain +! Lin et al. (1983) +! ======================================================================= + +subroutine psmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & + vtw, vtr, vts, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vts + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, factor, tmp, sink, qden, dqdt, tin, dq, qsi + real :: psacw, psacr, pracs + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .ge. 0. .and. qs (k) .gt. qcmin) then + + psacw = 0. + qden = qs (k) * den (k) + if (ql (k) .gt. qcmin) then + if (do_new_acc_water) then + psacw = acr3d (vts (k), vtw (k), ql (k), qs (k), csacw, acco (:, 7), & + acc (13), acc (14), den (k)) + else + factor = acr2d (qden, csacw, denfac (k), blins, mus) + psacw = factor / (1. + dts * factor) * ql (k) + endif + endif + + psacr = 0. + pracs = 0. + if (qr (k) .gt. qcmin) then + psacr = min (acr3d (vts (k), vtr (k), qr (k), qs (k), csacr, acco (:, 2), & + acc (3), acc (4), den (k)), qr (k) / dts) + pracs = acr3d (vtr (k), vts (k), qs (k), qr (k), cracs, acco (:, 1), & + acc (1), acc (2), den (k)) + endif + + tin = tz (k) + qsi = iqs (tin, den (k), dqdt) + dq = qsi - qv (k) + sink = max (0., pmlt (tc, dq, qden, psacw, psacr, csmlt, den (k), denfac (k), blins, mus, & + lcpk (k), icpk (k), cvm (k))) + + sink = min (qs (k), (sink + pracs) * dts, tc / icpk (k)) + tmp = min (sink, dim (qs_mlt, ql (k))) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., tmp, sink - tmp, 0., - sink, 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine psmlt + +! ======================================================================= +! graupel melting (includes graupel accretion with cloud water and rain) to form rain +! Lin et al. (1983) +! ======================================================================= + +subroutine pgmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & + vtw, vtr, vtg, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vtg + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, factor, sink, qden, dqdt, tin, dq, qsi + real :: pgacw, pgacr + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .ge. 0. .and. qg (k) .gt. qcmin) then + + pgacw = 0. + qden = qg (k) * den (k) + if (ql (k) .gt. qcmin) then + if (do_new_acc_water) then + pgacw = acr3d (vtg (k), vtw (k), ql (k), qg (k), cgacw, acco (:, 9), & + acc (17), acc (18), den (k)) + else + if (do_hail) then + factor = acr2d (qden, cgacw, denfac (k), blinh, muh) + else + factor = acr2d (qden, cgacw, denfac (k), bling, mug) + endif + pgacw = factor / (1. + dts * factor) * ql (k) + endif + endif + + pgacr = 0. + if (qr (k) .gt. qcmin) then + pgacr = min (acr3d (vtg (k), vtr (k), qr (k), qg (k), cgacr, acco (:, 3), & + acc (5), acc (6), den (k)), qr (k) / dts) + endif + + tin = tz (k) + qsi = iqs (tin, den (k), dqdt) + dq = qsi - qv (k) + if (do_hail) then + sink = max (0., pmlt (tc, dq, qden, pgacw, pgacr, cgmlt, den (k), denfac (k), & + blinh, muh, lcpk (k), icpk (k), cvm (k))) + else + sink = max (0., pmlt (tc, dq, qden, pgacw, pgacr, cgmlt, den (k), denfac (k), & + bling, mug, lcpk (k), icpk (k), cvm (k))) + endif + + sink = min (qg (k), sink * dts, tc / icpk (k)) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., sink, 0., 0., - sink, te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pgmlt + +! ======================================================================= +! snow accretion with cloud ice, Lin et al. (1983) +! ======================================================================= + +subroutine psaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vts) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke) :: den, denfac, vti, vts + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, factor, sink, qden + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .lt. 0. .and. qi (k) .gt. qcmin) then + + sink = 0. + qden = qs (k) * den (k) + if (qs (k) .gt. qcmin) then + if (do_new_acc_ice) then + sink = dts * acr3d (vts (k), vti (k), qi (k), qs (k), csaci, acco (:, 8), & + acc (15), acc (16), den (k)) + else + factor = dts * acr2d (qden, csaci, denfac (k), blins, mus) + sink = factor / (1. + factor) * qi (k) + endif + endif + + sink = min (fi2s_fac * qi (k), sink) + + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., - sink, sink, 0.) + + endif + + enddo + +end subroutine psaci + +! ======================================================================= +! cloud ice to snow autoconversion, Lin et al. (1983) +! ======================================================================= + +subroutine psaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, di) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke) :: den + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, di + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, sink, fac_i2s, q_plus, qim, dq, tmp + + fac_i2s = 1. - exp (- dts / tau_i2s) + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .lt. 0. .and. qi (k) .gt. qcmin) then + + sink = 0. + tmp = fac_i2s * exp (0.025 * tc) + di (k) = max (di (k), qcmin) + q_plus = qi (k) + di (k) + qim = qi0_crt / den (k) + if (q_plus .gt. (qim + qcmin)) then + if (qim .gt. (qi (k) - di (k))) then + dq = (0.25 * (q_plus - qim) ** 2) / di (k) + else + dq = qi (k) - qim + endif + sink = tmp * dq + endif + + sink = min (fi2s_fac * qi (k), sink) + + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., - sink, sink, 0.) + + endif + + enddo + +end subroutine psaut + +! ======================================================================= +! graupel accretion with cloud ice, Lin et al. (1983) +! ======================================================================= + +subroutine pgaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vtg) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke) :: den, denfac, vti, vtg + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, factor, sink, qden + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .lt. 0. .and. qi (k) .gt. qcmin) then + + sink = 0. + qden = qg (k) * den (k) + if (qg (k) .gt. qcmin) then + if (do_new_acc_ice) then + sink = dts * acr3d (vtg (k), vti (k), qi (k), qg (k), cgaci, acco (:, 10), & + acc (19), acc (20), den (k)) + else + if (do_hail) then + factor = dts * acr2d (qden, cgaci, denfac (k), blinh, muh) + else + factor = dts * acr2d (qden, cgaci, denfac (k), bling, mug) + endif + sink = factor / (1. + factor) * qi (k) + endif + endif + + sink = min (fi2g_fac * qi (k), sink) + + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., - sink, 0., sink) + + endif + + enddo + +end subroutine pgaci + +! ======================================================================= +! snow accretion with rain and rain freezing to form graupel, Lin et al. (1983) +! ======================================================================= + +subroutine psacr_pgfr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & + vtr, vts, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke) :: den, denfac, vtr, vts + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, factor, sink + real :: psacr, pgfr + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .lt. 0. .and. qr (k) .gt. qcmin) then + + psacr = 0. + if (qs (k) .gt. qcmin) then + psacr = dts * acr3d (vts (k), vtr (k), qr (k), qs (k), csacr, acco (:, 2), & + acc (3), acc (4), den (k)) + endif + + pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * & + exp ((6 + mur) / (mur + 3) * log (6 * qr (k) * den (k))) + + sink = psacr + pgfr + factor = min (sink, qr (k), - tc / icpk (k)) / max (sink, qcmin) + psacr = factor * psacr + pgfr = factor * pgfr + + sink = min (qr (k), psacr + pgfr) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., - sink, 0., psacr, pgfr, te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine psacr_pgfr + +! ======================================================================= +! graupel accretion with snow, Lin et al. (1983) +! ======================================================================= + +subroutine pgacs (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, vts, vtg) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke) :: den, vts, vtg + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: sink + + do k = ks, ke + + if (tz (k) .lt. tice .and. qs (k) .gt. qcmin .and. qg (k) .gt. qcmin) then + + sink = dts * acr3d (vtg (k), vts (k), qs (k), qg (k), cgacs, acco (:, 4), & + acc (7), acc (8), den (k)) + sink = min (fs2g_fac * qs (k), sink) + + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., 0., - sink, sink) + + endif + + enddo + +end subroutine pgacs + +! ======================================================================= +! snow to graupel autoconversion, Lin et al. (1983) +! ======================================================================= + +subroutine pgaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke) :: den + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, factor, sink, qsm + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .lt. 0. .and. qs (k) .gt. qcmin) then + + sink = 0 + qsm = qs0_crt / den (k) + if (qs (k) .gt. qsm) then + factor = dts * 1.e-3 * exp (0.09 * (tz (k) - tice)) + sink = factor / (1. + factor) * (qs (k) - qsm) + endif + + sink = min (fs2g_fac * qs (k), sink) + + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., 0., - sink, sink) + + endif + + enddo + +end subroutine pgaut + +! ======================================================================= +! graupel accretion with cloud water and rain, Lin et al. (1983) +! ======================================================================= + +subroutine pgacw_pgacr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & + vtr, vtg, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke) :: den, denfac, vtr, vtg + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, factor, sink, qden + real :: pgacw, pgacr + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .lt. 0. .and. qg (k) .gt. qcmin) then + + pgacw = 0. + if (ql (k) .gt. qcmin) then + qden = qg (k) * den (k) + if (do_hail) then + factor = dts * acr2d (qden, cgacw, denfac (k), blinh, muh) + else + factor = dts * acr2d (qden, cgacw, denfac (k), bling, mug) + endif + pgacw = factor / (1. + factor) * ql (k) + endif + + pgacr = 0. + if (qr (k) .gt. qcmin) then + pgacr = min (dts * acr3d (vtg (k), vtr (k), qr (k), qg (k), cgacr, acco (:, 3), & + acc (5), acc (6), den (k)), qr (k)) + endif + + sink = pgacr + pgacw + factor = min (sink, dim (tice, tz (k)) / icpk (k)) / max (sink, qcmin) + pgacr = factor * pgacr + pgacw = factor * pgacw + + sink = pgacr + pgacw + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - pgacw, - pgacr, 0., 0., sink, te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pgacw_pgacr + +! ======================================================================= +! temperature sentive high vertical resolution processes +! ======================================================================= + +subroutine subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, qr, & + qi, qs, qg, dp, ccn, cin, cond, dep, reevap, sub) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, rh_adj + + real, intent (in), dimension (ks:ke) :: den, denfac, dp + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn, cin + + real, intent (out) :: cond, dep, reevap, sub + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real, dimension (ks:ke) :: q_liq, q_sol, q_cond, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), dimension (ks:ke) :: cvm, te8 + + ! ----------------------------------------------------------------------- + ! initialization + ! ----------------------------------------------------------------------- + + cond = 0 + dep = 0 + reevap = 0 + sub = 0 + + ! ----------------------------------------------------------------------- + ! calculate heat capacities and latent heat coefficients + ! ----------------------------------------------------------------------- + + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & + lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! instant processes (include deposition, evaporation, and sublimation) + ! ----------------------------------------------------------------------- + + if (.not. do_warm_rain_mp) then + + call pinst (ks, ke, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, rh_adj, dep, sub, reevap) + + endif + + ! ----------------------------------------------------------------------- + ! cloud water condensation and evaporation + ! ----------------------------------------------------------------------- + + call pcond_pevap (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, cond, reevap) + + if (.not. do_warm_rain_mp) then + + ! ----------------------------------------------------------------------- + ! enforce complete freezing below t_wfr + ! ----------------------------------------------------------------------- + + call pcomp (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! Wegener Bergeron Findeisen process + ! ----------------------------------------------------------------------- + + call pwbf (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! Bigg freezing mechanism + ! ----------------------------------------------------------------------- + + call pbigg (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, ccn, lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! cloud ice deposition and sublimation + ! ----------------------------------------------------------------------- + + call pidep_pisub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, cin, dep, sub) + + ! ----------------------------------------------------------------------- + ! snow deposition and sublimation + ! ----------------------------------------------------------------------- + + call psdep_pssub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + denfac, lcpk, icpk, tcpk, tcp3, dep, sub) + + ! ----------------------------------------------------------------------- + ! graupel deposition and sublimation + ! ----------------------------------------------------------------------- + + call pgdep_pgsub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + denfac, lcpk, icpk, tcpk, tcp3, dep, sub) + + endif + +end subroutine subgrid_z_proc + +! ======================================================================= +! instant processes (include deposition, evaporation, and sublimation) +! ======================================================================= + +subroutine pinst (ks, ke, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, rh_adj, dep, sub, reevap) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: rh_adj + + real, intent (in), dimension (ks:ke) :: den, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (out) :: dep, reevap, sub + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: sink, tin, qpz, rh, dqdt, tmp, qsi + + do k = ks, ke + + ! ----------------------------------------------------------------------- + ! instant deposit all water vapor to cloud ice when temperature is super low + ! ----------------------------------------------------------------------- + + if (tz (k) .lt. t_min) then + + sink = dim (qv (k), qcmin) + dep = dep + sink * dp (k) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + - sink, 0., 0., sink, 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + ! ----------------------------------------------------------------------- + ! instant evaporation / sublimation of all clouds when rh < rh_adj + ! ----------------------------------------------------------------------- + + qpz = qv (k) + ql (k) + qi (k) + tin = (te8 (k) - lv00 * qpz + li00 * (qs (k) + qg (k))) / & + mhc (qpz, qr (k), qs (k) + qg (k)) + + if (tin .gt. t_sub + 6.) then + + qsi = iqs (tin, den (k), dqdt) + rh = qpz / qsi + if (rh .lt. rh_adj) then + + sink = ql (k) + tmp = qi (k) + + reevap = reevap + sink * dp (k) + sub = sub + tmp * dp (k) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + sink + tmp, - sink, 0., - tmp, 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + endif + + enddo + +end subroutine pinst + +! ======================================================================= +! cloud water condensation and evaporation, Hong and Lim (2006) +! ======================================================================= + +subroutine pcond_pevap (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, cond, reevap) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke) :: den, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (out) :: cond, reevap + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: sink, tin, qpz, dqdt, qsw, rh_tem, dq, factor, fac_l2v, fac_v2l + + fac_l2v = 1. - exp (- dts / tau_l2v) + fac_v2l = 1. - exp (- dts / tau_v2l) + + do k = ks, ke + + tin = tz (k) + qsw = wqs (tin, den (k), dqdt) + qpz = qv (k) + ql (k) + qi (k) + rh_tem = qpz / qsw + dq = qsw - qv (k) + if (dq .gt. 0.) then + factor = min (1., fac_l2v * (rh_fac * dq / qsw)) + sink = min (ql (k), factor * dq / (1. + tcp3 (k) * dqdt)) + if (use_rhc_cevap .and. rh_tem .ge. rhc_cevap) then + sink = 0. + endif + reevap = reevap + sink * dp (k) + elseif (do_cond_timescale) then + factor = min (1., fac_v2l * (rh_fac * (- dq) / qsw)) + sink = - min (qv (k), factor * (- dq) / (1. + tcp3 (k) * dqdt)) + cond = cond - sink * dp (k) + else + sink = - min (qv (k), - dq / (1. + tcp3 (k) * dqdt)) + cond = cond - sink * dp (k) + endif + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + sink, - sink, 0., 0., 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + enddo + +end subroutine pcond_pevap + +! ======================================================================= +! enforce complete freezing below t_wfr, Lin et al. (1983) +! ======================================================================= + +subroutine pcomp (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, sink + + do k = ks, ke + + tc = t_wfr - tz (k) + + if (tc .gt. 0. .and. ql (k) .gt. qcmin) then + + sink = ql (k) * tc / dt_fr + sink = min (ql (k), sink, tc / icpk (k)) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, 0., sink, 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pcomp + +! ======================================================================= +! Wegener Bergeron Findeisen process, Storelvmo and Tan (2015) +! ======================================================================= + +subroutine pwbf (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke) :: den + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, tin, sink, dqdt, qsw, qsi, qim, tmp, fac_wbf + + if (.not. do_wbf) return + + fac_wbf = 1. - exp (- dts / tau_wbf) + + do k = ks, ke + + tc = tice - tz (k) + + tin = tz (k) + qsw = wqs (tin, den (k), dqdt) + qsi = iqs (tin, den (k), dqdt) + + if (tc .gt. 0. .and. ql (k) .gt. qcmin .and. qi (k) .gt. qcmin .and. & + qv (k) .gt. qsi .and. qv (k) .lt. qsw) then + + sink = min (fac_wbf * ql (k), tc / icpk (k)) + qim = qi0_crt / den (k) + tmp = min (sink, dim (qim, qi (k))) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, 0., tmp, sink - tmp, 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pwbf + +! ======================================================================= +! Bigg freezing mechanism, Bigg (1953) +! ======================================================================= + +subroutine pbigg (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, ccn, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke) :: den + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: sink, tc + + do k = ks, ke + + tc = tice - tz (k) + + if (tc .gt. 0 .and. ql (k) .gt. qcmin) then + + if (do_psd_water_num) then + call cal_pc_ed_oe_rr_tv (ql (k), den (k), blinw, muw, & + pca = pcaw, pcb = pcbw, pc = ccn (k)) + ccn (k) = ccn (k) / den (k) + endif + + sink = 100. / (rhow * ccn (k)) * dts * (exp (0.66 * tc) - 1.) * ql (k) ** 2 + sink = min (ql (k), sink, tc / icpk (k)) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, 0., sink, 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pbigg + +! ======================================================================= +! cloud ice deposition and sublimation, Hong et al. (2004) +! ======================================================================= + +subroutine pidep_pisub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, cin, dep, sub) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke) :: den, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, cin + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (out) :: dep, sub + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: sink, tin, dqdt, qsi, dq, pidep, tmp, tc, qi_gen, qi_crt + + do k = ks, ke + + if (tz (k) .lt. tice) then + + pidep = 0. + tin = tz (k) + qsi = iqs (tin, den (k), dqdt) + dq = qv (k) - qsi + tmp = dq / (1. + tcpk (k) * dqdt) + + if (qi (k) .gt. qcmin) then + if (.not. prog_ccn) then + if (inflag .eq. 1) & + cin (k) = 5.38e7 * exp (0.75 * log (qi (k) * den (k))) + if (inflag .eq. 2) & + cin (k) = exp (- 2.80 + 0.262 * (tice - tz (k))) * 1000.0 + if (inflag .eq. 3) & + cin (k) = exp (- 0.639 + 12.96 * (qv (k) / qsi - 1.0)) * 1000.0 + if (inflag .eq. 4) & + cin (k) = 5.e-3 * exp (0.304 * (tice - tz (k))) * 1000.0 + if (inflag .eq. 5) & + cin (k) = 1.e-5 * exp (0.5 * (tice - tz (k))) * 1000.0 + endif + if (do_psd_ice_num) then + call cal_pc_ed_oe_rr_tv (qi (k), den (k), blini, mui, & + pca = pcai, pcb = pcbi, pc = cin (k)) + cin (k) = cin (k) / den (k) + endif + pidep = dts * dq * 4.0 * 11.9 * exp (0.5 * log (qi (k) * den (k) * cin (k))) / & + (qsi * den (k) * (tcpk (k) * cvm (k)) ** 2 / (tcond * rvgas * tz (k) ** 2) + & + 1. / vdifu) + endif + + if (dq .gt. 0.) then + tc = tice - tz (k) + qi_gen = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tc))) + if (igflag .eq. 1) & + qi_crt = qi_gen / den (k) + if (igflag .eq. 2) & + qi_crt = qi_gen * min (qi_lim, 0.1 * tc) / den (k) + if (igflag .eq. 3) & + qi_crt = 1.82e-6 * min (qi_lim, 0.1 * tc) / den (k) + if (igflag .eq. 4) & + qi_crt = max (qi_gen, 1.82e-6) * min (qi_lim, 0.1 * tc) / den (k) + sink = min (tmp, max (qi_crt - qi (k), pidep), tc / tcpk (k)) + dep = dep + sink * dp (k) + else + pidep = pidep * min (1., dim (tz (k), t_sub) * is_fac) + sink = max (pidep, tmp, - qi (k)) + sub = sub - sink * dp (k) + endif + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + - sink, 0., 0., sink, 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pidep_pisub + +! ======================================================================= +! snow deposition and sublimation, Lin et al. (1983) +! ======================================================================= + +subroutine psdep_pssub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + denfac, lcpk, icpk, tcpk, tcp3, dep, sub) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke) :: den, dp, denfac + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (out) :: dep, sub + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: sink, tin, dqdt, qsi, qden, t2, dq, pssub + + do k = ks, ke + + if (qs (k) .gt. qcmin) then + + tin = tz (k) + qsi = iqs (tin, den (k), dqdt) + qden = qs (k) * den (k) + t2 = tz (k) * tz (k) + dq = qsi - qv (k) + pssub = psub (t2, dq, qden, qsi, cssub, den (k), denfac (k), blins, mus, tcpk (k), cvm (k)) + pssub = dts * pssub + dq = dq / (1. + tcpk (k) * dqdt) + if (pssub .gt. 0.) then + sink = min (pssub * min (1., dim (tz (k), t_sub) * ss_fac), qs (k)) + sub = sub + sink * dp (k) + else + sink = 0. + if (tz (k) .le. tice) then + sink = max (pssub, dq, (tz (k) - tice) / tcpk (k)) + endif + dep = dep - sink * dp (k) + endif + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + sink, 0., 0., 0., - sink, 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine psdep_pssub + +! ======================================================================= +! graupel deposition and sublimation, Lin et al. (1983) +! ======================================================================= + +subroutine pgdep_pgsub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + denfac, lcpk, icpk, tcpk, tcp3, dep, sub) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke) :: den, dp, denfac + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (out) :: dep, sub + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: sink, tin, dqdt, qsi, qden, t2, dq, pgsub + + do k = ks, ke + + if (qg (k) .gt. qcmin) then + + tin = tz (k) + qsi = iqs (tin, den (k), dqdt) + qden = qg (k) * den (k) + t2 = tz (k) * tz (k) + dq = qsi - qv (k) + if (do_hail) then + pgsub = psub (t2, dq, qden, qsi, cgsub, den (k), denfac (k), & + blinh, muh, tcpk (k), cvm (k)) + else + pgsub = psub (t2, dq, qden, qsi, cgsub, den (k), denfac (k), & + bling, mug, tcpk (k), cvm (k)) + endif + pgsub = dts * pgsub + dq = dq / (1. + tcpk (k) * dqdt) + if (pgsub .gt. 0.) then + sink = min (pgsub * min (1., dim (tz (k), t_sub) * gs_fac), qg (k)) + sub = sub + sink * dp (k) + else + sink = 0. + if (tz (k) .le. tice) then + sink = max (pgsub, dq, (tz (k) - tice) / tcpk (k)) + endif + dep = dep - sink * dp (k) + endif + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + sink, 0., 0., 0., 0., - sink, te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pgdep_pgsub + +! ======================================================================= +! cloud fraction diagnostic +! ======================================================================= + +subroutine cloud_fraction (ks, ke, pz, den, qv, ql, qr, qi, qs, qg, qa, tz, h_var, gsize) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: h_var, gsize + + real, intent (in), dimension (ks:ke) :: pz, den + + real (kind = r8), intent (in), dimension (ks:ke) :: tz + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, qa + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: q_plus, q_minus + real :: rh, rqi, tin, qsw, qsi, qpz, qstar, sigma, gam + real :: dqdt, dq, liq, ice + real :: qa10, qa100 + + real, dimension (ks:ke) :: q_liq, q_sol, q_cond, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), dimension (ks:ke) :: cvm, te8 + + ! ----------------------------------------------------------------------- + ! calculate heat capacities and latent heat coefficients + ! ----------------------------------------------------------------------- + + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & + lcpk, icpk, tcpk, tcp3) + + do k = ks, ke + + ! combine water species + + ice = q_sol (k) + q_sol (k) = qi (k) + if (rad_snow) then + q_sol (k) = qi (k) + qs (k) + if (rad_graupel) then + q_sol (k) = qi (k) + qs (k) + qg (k) + endif + endif + + liq = q_liq (k) + q_liq (k) = ql (k) + if (rad_rain) then + q_liq (k) = ql (k) + qr (k) + endif + + q_cond (k) = q_liq (k) + q_sol (k) + qpz = qv (k) + q_cond (k) + + ! use the "liquid - frozen water temperature" (tin) to compute saturated specific humidity + + ice = ice - q_sol (k) + liq = liq - q_liq (k) + tin = (te8 (k) - lv00 * qpz + li00 * ice) / mhc (qpz, liq, ice) + + ! calculate saturated specific humidity + + if (tin .le. t_wfr) then + qstar = iqs (tin, den (k), dqdt) + elseif (tin .ge. tice) then + qstar = wqs (tin, den (k), dqdt) + else + qsi = iqs (tin, den (k), dqdt) + qsw = wqs (tin, den (k), dqdt) + if (q_cond (k) .gt. qcmin) then + rqi = q_sol (k) / q_cond (k) + else + rqi = (tice - tin) / (tice - t_wfr) + endif + qstar = rqi * qsi + (1. - rqi) * qsw + endif + + ! cloud schemes + + rh = qpz / qstar + + if (cfflag .eq. 1) then + if (rh .gt. rh_thres .and. qpz .gt. qcmin) then + + dq = h_var * qpz + if (do_cld_adj) then + q_plus = qpz + dq * f_dq_p * min (1.0, max (0.0, (pz (k) - 200.e2) / & + (1000.e2 - 200.e2))) + else + q_plus = qpz + dq * f_dq_p + endif + q_minus = qpz - dq * f_dq_m + + if (icloud_f .eq. 2) then + if (qstar .lt. qpz) then + qa (k) = 1. + else + qa (k) = 0. + endif + elseif (icloud_f .eq. 3) then + if (qstar .lt. qpz) then + qa (k) = 1. + else + if (qstar .lt. q_plus) then + qa (k) = (q_plus - qstar) / (dq * f_dq_p) + else + qa (k) = 0. + endif + if (q_cond (k) .gt. qcmin) then + qa (k) = max (cld_min, qa (k)) + endif + qa (k) = min (1., qa (k)) + endif + else + if (qstar .lt. q_minus) then + qa (k) = 1. + else + if (qstar .lt. q_plus) then + if (icloud_f .eq. 0) then + qa (k) = (q_plus - qstar) / (dq * f_dq_p + dq * f_dq_m) + else + qa (k) = (q_plus - qstar) / ((dq * f_dq_p + dq * f_dq_m) * & + (1. - q_cond (k))) + endif + else + qa (k) = 0. + endif + if (q_cond (k) .gt. qcmin) then + qa (k) = max (cld_min, qa (k)) + endif + qa (k) = min (1., qa (k)) + endif + endif + else + qa (k) = 0. + endif + endif + + if (cfflag .eq. 2) then + if (rh .ge. 1.0) then + qa (k) = 1.0 + elseif (rh .gt. rh_thres .and. q_cond (k) .gt. qcmin) then + qa (k) = exp (xr_a * log (rh)) * (1.0 - exp (- xr_b * max (0.0, q_cond (k)) / & + max (1.e-5, exp (xr_c * log (max (1.e-10, 1.0 - rh) * qstar))))) + qa (k) = max (0.0, min (1., qa (k))) + else + qa (k) = 0.0 + endif + endif + + if (cfflag .eq. 3) then + if (q_cond (k) .gt. qcmin) then + qa (k) = 1. / 50. * (5.77 * (100. - gsize / 1000.) * & + exp (1.07 * log (max (qcmin * 1000., q_cond (k) * 1000.))) + & + 4.82 * (gsize / 1000. - 50.) * & + exp (0.94 * log (max (qcmin * 1000., q_cond (k) * 1000.)))) + qa (k) = qa (k) * (0.92 / 0.96 * q_liq (k) / q_cond (k) + & + 1.0 / 0.96 * q_sol (k) / q_cond (k)) + qa (k) = max (0.0, min (1., qa (k))) + else + qa (k) = 0.0 + endif + endif + + if (cfflag .eq. 4) then + sigma = 0.28 + exp (0.49 * log (max (qcmin * 1000., q_cond (k) * 1000.))) + gam = max (0.0, q_cond (k) * 1000.) / sigma + if (gam .lt. 0.18) then + qa10 = 0. + elseif (gam .gt. 2.0) then + qa10 = 1.0 + else + qa10 = - 0.1754 + 0.9811 * gam - 0.2223 * gam ** 2 + 0.0104 * gam ** 3 + qa10 = max (0.0, min (1., qa10)) + endif + if (gam .lt. 0.12) then + qa100 = 0. + elseif (gam .gt. 1.85) then + qa100 = 1.0 + else + qa100 = - 0.0913 + 0.7213 * gam + 0.1060 * gam ** 2 - 0.0946 * gam ** 3 + qa100 = max (0.0, min (1., qa100)) + endif + qa (k) = qa10 + (log10 (gsize / 1000.) - 1) * (qa100 - qa10) + qa (k) = max (0.0, min (1., qa (k))) + endif + + enddo + +end subroutine cloud_fraction + +! ======================================================================= +! piecewise parabolic lagrangian scheme +! this subroutine is the same as map1_q2 in fv_mapz_mod. +! ======================================================================= + +subroutine lagrangian_fall (ks, ke, zs, ze, zt, dp, q, precip, m1) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: zs + + real, intent (in), dimension (ks:ke + 1) :: ze, zt + + real, intent (in), dimension (ks:ke) :: dp + + real, intent (inout), dimension (ks:ke) :: q + + real, intent (inout) :: precip + + real, intent (out), dimension (ks:ke) :: m1 + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k, k0, n, m + + real :: a4 (4, ks:ke), pl, pr, delz, esl + + real, parameter :: r3 = 1. / 3., r23 = 2. / 3. + + real, dimension (ks:ke) :: qm, dz + + ! ----------------------------------------------------------------------- + ! density: + ! ----------------------------------------------------------------------- + + do k = ks, ke + dz (k) = zt (k) - zt (k + 1) + q (k) = q (k) * dp (k) + a4 (1, k) = q (k) / dz (k) + qm (k) = 0. + enddo + + ! ----------------------------------------------------------------------- + ! construct vertical profile with zt as coordinate + ! ----------------------------------------------------------------------- + + call cs_profile (a4 (1, ks), dz (ks), ke - ks + 1) + + k0 = ks + do k = ks, ke + do n = k0, ke + if (ze (k) .le. zt (n) .and. ze (k) .ge. zt (n + 1)) then + pl = (zt (n) - ze (k)) / dz (n) + if (zt (n + 1) .le. ze (k + 1)) then + ! entire new grid is within the original grid + pr = (zt (n) - ze (k + 1)) / dz (n) + qm (k) = a4 (2, n) + 0.5 * (a4 (4, n) + a4 (3, n) - a4 (2, n)) * (pr + pl) - & + a4 (4, n) * r3 * (pr * (pr + pl) + pl ** 2) + qm (k) = qm (k) * (ze (k) - ze (k + 1)) + k0 = n + goto 555 + else + qm (k) = (ze (k) - zt (n + 1)) * (a4 (2, n) + 0.5 * (a4 (4, n) + & + a4 (3, n) - a4 (2, n)) * (1. + pl) - a4 (4, n) * (r3 * (1. + pl * (1. + pl)))) + if (n .lt. ke) then + do m = n + 1, ke + ! locate the bottom edge: ze (k + 1) + if (ze (k + 1) .lt. zt (m + 1)) then + qm (k) = qm (k) + q (m) + else + delz = zt (m) - ze (k + 1) + esl = delz / dz (m) + qm (k) = qm (k) + delz * (a4 (2, m) + 0.5 * esl * & + (a4 (3, m) - a4 (2, m) + a4 (4, m) * (1. - r23 * esl))) + k0 = m + goto 555 + endif + enddo + endif + goto 555 + endif + endif + enddo + 555 continue + enddo + + m1 (ks) = q (ks) - qm (ks) + do k = ks + 1, ke + m1 (k) = m1 (k - 1) + q (k) - qm (k) + enddo + precip = precip + m1 (ke) + + ! ----------------------------------------------------------------------- + ! convert back to * dry * mixing ratio: + ! dp must be dry air_mass (because moist air mass will be changed due to terminal fall) . + ! ----------------------------------------------------------------------- + + do k = ks, ke + q (k) = qm (k) / dp (k) + enddo + +end subroutine lagrangian_fall + +! ======================================================================= +! vertical profile reconstruction +! this subroutine is the same as cs_profile in fv_mapz_mod where iv = 0 and kord = 9 +! ======================================================================= + +subroutine cs_profile (a4, del, km) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: km + + real, intent (in) :: del (km) + + real, intent (inout) :: a4 (4, km) + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + logical :: extm (km) + + real :: gam (km), q (km + 1), d4, bet, a_bot, grat, pmp, lac + real :: pmp_1, lac_1, pmp_2, lac_2, da1, da2, a6da + + grat = del (2) / del (1) ! grid ratio + bet = grat * (grat + 0.5) + q (1) = (2. * grat * (grat + 1.) * a4 (1, 1) + a4 (1, 2)) / bet + gam (1) = (1. + grat * (grat + 1.5)) / bet + + do k = 2, km + d4 = del (k - 1) / del (k) + bet = 2. + 2. * d4 - gam (k - 1) + q (k) = (3. * (a4 (1, k - 1) + d4 * a4 (1, k)) - q (k - 1)) / bet + gam (k) = d4 / bet + enddo + + a_bot = 1. + d4 * (d4 + 1.5) + q (km + 1) = (2. * d4 * (d4 + 1.) * a4 (1, km) + a4 (1, km - 1) - a_bot * q (km)) & + / (d4 * (d4 + 0.5) - a_bot * gam (km)) + + do k = km, 1, - 1 + q (k) = q (k) - gam (k) * q (k + 1) + enddo + + ! ----------------------------------------------------------------------- + ! apply constraints + ! ----------------------------------------------------------------------- + + do k = 2, km + gam (k) = a4 (1, k) - a4 (1, k - 1) + enddo + + ! ----------------------------------------------------------------------- + ! top: + ! ----------------------------------------------------------------------- + + q (1) = max (q (1), 0.) + q (2) = min (q (2), max (a4 (1, 1), a4 (1, 2))) + q (2) = max (q (2), min (a4 (1, 1), a4 (1, 2)), 0.) + + ! ----------------------------------------------------------------------- + ! interior: + ! ----------------------------------------------------------------------- + + do k = 3, km - 1 + if (gam (k - 1) * gam (k + 1) .gt. 0.) then + ! apply large - scale constraints to all fields if not local max / min + q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) + q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) + else + if (gam (k - 1) .gt. 0.) then + ! there exists a local max + q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) + else + ! there exists a local min + q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) + ! positive-definite + q (k) = max (q (k), 0.0) + endif + endif + enddo + + ! ----------------------------------------------------------------------- + ! bottom: + ! ----------------------------------------------------------------------- + + q (km) = min (q (km), max (a4 (1, km - 1), a4 (1, km))) + q (km) = max (q (km), min (a4 (1, km - 1), a4 (1, km)), 0.) + q (km + 1) = max (q (km + 1), 0.) + + do k = 1, km + a4 (2, k) = q (k) + a4 (3, k) = q (k + 1) + enddo + + do k = 1, km + if (k .eq. 1 .or. k .eq. km) then + extm (k) = (a4 (2, k) - a4 (1, k)) * (a4 (3, k) - a4 (1, k)) .gt. 0. + else + extm (k) = gam (k) * gam (k + 1) .lt. 0. + endif + enddo + + ! ----------------------------------------------------------------------- + ! apply constraints + ! f (s) = al + s * [ (ar - al) + a6 * (1 - s) ] (0 <= s <= 1) + ! always use monotonic mapping + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! top: + ! ----------------------------------------------------------------------- + + a4 (2, 1) = max (0., a4 (2, 1)) + + ! ----------------------------------------------------------------------- + ! Huynh's 2nd constraint for interior: + ! ----------------------------------------------------------------------- + + do k = 3, km - 2 + if (extm (k)) then + ! positive definite constraint only if true local extrema + if (a4 (1, k) .lt. qcmin .or. extm (k - 1) .or. extm (k + 1)) then + a4 (2, k) = a4 (1, k) + a4 (3, k) = a4 (1, k) + endif + else + a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k)) + if (abs (a4 (4, k)) .gt. abs (a4 (2, k) - a4 (3, k))) then + ! check within the smooth region if subgrid profile is non - monotonic + pmp_1 = a4 (1, k) - 2.0 * gam (k + 1) + lac_1 = pmp_1 + 1.5 * gam (k + 2) + a4 (2, k) = min (max (a4 (2, k), min (a4 (1, k), pmp_1, lac_1)), & + max (a4 (1, k), pmp_1, lac_1)) + pmp_2 = a4 (1, k) + 2.0 * gam (k) + lac_2 = pmp_2 - 1.5 * gam (k - 1) + a4 (3, k) = min (max (a4 (3, k), min (a4 (1, k), pmp_2, lac_2)), & + max (a4 (1, k), pmp_2, lac_2)) + endif + endif + enddo + + do k = 1, km - 1 + a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k)) + enddo + + k = km - 1 + if (extm (k)) then + a4 (2, k) = a4 (1, k) + a4 (3, k) = a4 (1, k) + a4 (4, k) = 0. + else + da1 = a4 (3, k) - a4 (2, k) + da2 = da1 ** 2 + a6da = a4 (4, k) * da1 + if (a6da .lt. - da2) then + a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) + a4 (3, k) = a4 (2, k) - a4 (4, k) + elseif (a6da .gt. da2) then + a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) + a4 (2, k) = a4 (3, k) - a4 (4, k) + endif + endif + + call cs_limiters (km - 1, a4) + + ! ----------------------------------------------------------------------- + ! bottom: + ! ----------------------------------------------------------------------- + + a4 (2, km) = a4 (1, km) + a4 (3, km) = a4 (1, km) + a4 (4, km) = 0. + +end subroutine cs_profile + +! ======================================================================= +! cubic spline (cs) limiters or boundary conditions +! a positive-definite constraint (iv = 0) is applied to tracers in every layer, +! adjusting the top-most and bottom-most interface values to enforce positive. +! this subroutine is the same as cs_limiters in fv_mapz_mod where iv = 0. +! ======================================================================= + +subroutine cs_limiters (km, a4) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: km + + real, intent (inout) :: a4 (4, km) ! ppm array + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real, parameter :: r12 = 1. / 12. + + do k = 1, km + if (a4 (1, k) .le. 0.) then + a4 (2, k) = a4 (1, k) + a4 (3, k) = a4 (1, k) + a4 (4, k) = 0. + else + if (abs (a4 (3, k) - a4 (2, k)) .lt. - a4 (4, k)) then + if ((a4 (1, k) + 0.25 * (a4 (3, k) - a4 (2, k)) ** 2 / a4 (4, k) + & + a4 (4, k) * r12) .lt. 0.) then + ! local minimum is negative + if (a4 (1, k) .lt. a4 (3, k) .and. a4 (1, k) .lt. a4 (2, k)) then + a4 (3, k) = a4 (1, k) + a4 (2, k) = a4 (1, k) + a4 (4, k) = 0. + elseif (a4 (3, k) .gt. a4 (2, k)) then + a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) + a4 (3, k) = a4 (2, k) - a4 (4, k) + else + a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) + a4 (2, k) = a4 (3, k) - a4 (4, k) + endif + endif + endif + endif + enddo + +end subroutine cs_limiters + +! ======================================================================= +! time-implicit monotonic scheme +! ======================================================================= + +subroutine implicit_fall (dts, ks, ke, ze, vt, dp, q, precip, m1) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke + 1) :: ze + + real, intent (in), dimension (ks:ke) :: vt, dp + + real, intent (inout), dimension (ks:ke) :: q + + real, intent (inout) :: precip + + real, intent (out), dimension (ks:ke) :: m1 + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real, dimension (ks:ke) :: dz, qm, dd + + do k = ks, ke + dz (k) = ze (k) - ze (k + 1) + dd (k) = dts * vt (k) + q (k) = q (k) * dp (k) + enddo + + qm (ks) = q (ks) / (dz (ks) + dd (ks)) + do k = ks + 1, ke + qm (k) = (q (k) + qm (k - 1) * dd (k - 1)) / (dz (k) + dd (k)) + enddo + + do k = ks, ke + qm (k) = qm (k) * dz (k) + enddo + + m1 (ks) = q (ks) - qm (ks) + do k = ks + 1, ke + m1 (k) = m1 (k - 1) + q (k) - qm (k) + enddo + precip = precip + m1 (ke) + + do k = ks, ke + q (k) = qm (k) / dp (k) + enddo + +end subroutine implicit_fall + +! ======================================================================= +! time-explicit monotonic scheme +! ======================================================================= + +subroutine explicit_fall (dts, ks, ke, ze, vt, dp, q, precip, m1) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke + 1) :: ze + + real, intent (in), dimension (ks:ke) :: vt, dp + + real, intent (inout), dimension (ks:ke) :: q + + real, intent (inout) :: precip + + real, intent (out), dimension (ks:ke) :: m1 + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: n, k, nstep + + real, dimension (ks:ke) :: dz, qm, q0, dd + + do k = ks, ke + dz (k) = ze (k) - ze (k + 1) + dd (k) = dts * vt (k) + q0 (k) = q (k) * dp (k) + enddo + + nstep = 1 + int (maxval (dd / dz)) + do k = ks, ke + dd (k) = dd (k) / nstep + q (k) = q0 (k) + enddo + + do n = 1, nstep + qm (ks) = q (ks) - q (ks) * dd (ks) / dz (ks) + do k = ks + 1, ke + qm (k) = q (k) - q (k) * dd (k) / dz (k) + q (k - 1) * dd (k - 1) / dz (k - 1) + enddo + q = qm + enddo + + m1 (ks) = q0 (ks) - qm (ks) + do k = ks + 1, ke + m1 (k) = m1 (k - 1) + q0 (k) - qm (k) + enddo + precip = precip + m1 (ke) + + do k = ks, ke + q (k) = qm (k) / dp (k) + enddo + +end subroutine explicit_fall + +! ======================================================================= +! combine time-implicit monotonic scheme with the piecewise parabolic lagrangian scheme +! ======================================================================= + +subroutine implicit_lagrangian_fall (dts, ks, ke, zs, ze, zt, vt, dp, q, & + precip, flux, sed_fac) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: zs, dts, sed_fac + + real, intent (in), dimension (ks:ke + 1) :: ze, zt + + real, intent (in), dimension (ks:ke) :: vt, dp + + real, intent (inout), dimension (ks:ke) :: q + + real, intent (inout) :: precip + + real, intent (out), dimension (ks:ke) :: flux + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real :: pre0, pre1 + + real, dimension (ks:ke) :: q0, q1, m0, m1 + + q0 = q + pre0 = precip + + call implicit_fall (dts, ks, ke, ze, vt, dp, q0, pre0, m0) + + q1 = q + pre1 = precip + + call lagrangian_fall (ks, ke, zs, ze, zt, dp, q1, pre1, m1) + + q = q0 * sed_fac + q1 * (1.0 - sed_fac) + flux = m0 * sed_fac + m1 * (1.0 - sed_fac) + precip = pre0 * sed_fac + pre1 * (1.0 - sed_fac) + +end subroutine implicit_lagrangian_fall + +! ======================================================================= +! vertical subgrid variability used for cloud ice and cloud water autoconversion +! edges: qe == qbar + / - dm +! ======================================================================= + +subroutine linear_prof (km, q, dm, z_var, h_var) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: km + + logical, intent (in) :: z_var + + real, intent (in) :: q (km), h_var + + real, intent (out) :: dm (km) + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: dq (km) + + if (z_var) then + do k = 2, km + dq (k) = 0.5 * (q (k) - q (k - 1)) + enddo + dm (1) = 0. + ! ----------------------------------------------------------------------- + ! use twice the strength of the positive definiteness limiter (Lin et al. 1994) + ! ----------------------------------------------------------------------- + do k = 2, km - 1 + dm (k) = 0.5 * min (abs (dq (k) + dq (k + 1)), 0.5 * q (k)) + if (dq (k) * dq (k + 1) .le. 0.) then + if (dq (k) .gt. 0.) then + dm (k) = min (dm (k), dq (k), - dq (k + 1)) + else + dm (k) = 0. + endif + endif + enddo + dm (km) = 0. + ! ----------------------------------------------------------------------- + ! impose a presumed background horizontal variability that is proportional to the value itself + ! ----------------------------------------------------------------------- + do k = 1, km + dm (k) = max (dm (k), 0.0, h_var * q (k)) + enddo + else + do k = 1, km + dm (k) = max (0.0, h_var * q (k)) + enddo + endif + +end subroutine linear_prof + +! ======================================================================= +! accretion function, Lin et al. (1983) +! ======================================================================= + +function acr2d (qden, c, denfac, blin, mu) + + implicit none + + real :: acr2d + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: qden, c, denfac, blin, mu + + acr2d = denfac * c * exp ((2 + mu + blin) / (mu + 3) * log (6 * qden)) + +end function acr2d + +! ======================================================================= +! accretion function, Lin et al. (1983) +! ======================================================================= + +function acr3d (v1, v2, q1, q2, c, acco, acc1, acc2, den) + + implicit none + + real :: acr3d + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: v1, v2, c, den, q1, q2, acco (3), acc1, acc2 + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: i + + real :: t1, t2, tmp, vdiff + + t1 = exp (1. / (acc1 + 3) * log (6 * q1 * den)) + t2 = exp (1. / (acc2 + 3) * log (6 * q2 * den)) + + if (vdiffflag .eq. 1) vdiff = abs (v1 - v2) + if (vdiffflag .eq. 2) vdiff = sqrt ((1.20 * v1 - 0.95 * v2) ** 2. + 0.08 * v1 * v2) + if (vdiffflag .eq. 3) vdiff = sqrt ((1.00 * v1 - 1.00 * v2) ** 2. + 0.04 * v1 * v2) + + acr3d = c * vdiff / den + + tmp = 0 + do i = 1, 3 + tmp = tmp + acco (i) * exp ((6 + acc1 - i) * log (t1)) * exp ((acc2 + i - 1) * log (t2)) + enddo + + acr3d = acr3d * tmp + +end function acr3d + +! ======================================================================= +! ventilation coefficient, Lin et al. (1983) +! ======================================================================= + +function vent_coeff (qden, c1, c2, denfac, blin, mu) + + implicit none + + real :: vent_coeff + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: qden, c1, c2, denfac, blin, mu + + vent_coeff = c1 + c2 * exp ((3 + 2 * mu + blin) / (mu + 3) / 2 * log (6 * qden)) * & + sqrt (denfac) / exp ((1 + mu) / (mu + 3) * log (6 * qden)) + +end function vent_coeff + +! ======================================================================= +! sublimation or evaporation function, Lin et al. (1983) +! ======================================================================= + +function psub (t2, dq, qden, qsat, c, den, denfac, blin, mu, cpk, cvm) + + implicit none + + real :: psub + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: t2, dq, qden, qsat, c (5), den, denfac, blin, cpk, mu + + real (kind = r8), intent (in) :: cvm + + psub = c (1) * t2 * dq * exp ((1 + mu) / (mu + 3) * log (6 * qden)) * & + vent_coeff (qden, c (2), c (3), denfac, blin, mu) / & + (c (4) * t2 + c (5) * (cpk * cvm) ** 2 * qsat * den) + +end function psub + +! ======================================================================= +! melting function, Lin et al. (1983) +! ======================================================================= + +function pmlt (tc, dq, qden, pxacw, pxacr, c, den, denfac, blin, mu, lcpk, icpk, cvm) + + implicit none + + real :: pmlt + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tc, dq, qden, pxacw, pxacr, c (4), den, denfac, blin, lcpk, icpk, mu + + real (kind = r8), intent (in) :: cvm + + pmlt = (c (1) / (icpk * cvm) * tc / den - c (2) * lcpk / icpk * dq) * & + exp ((1 + mu) / (mu + 3) * log (6 * qden)) * & + vent_coeff (qden, c (3), c (4), denfac, blin, mu) + & + c_liq / (icpk * cvm) * tc * (pxacw + pxacr) + +end function pmlt + +! ======================================================================= +! sedimentation of horizontal momentum +! ======================================================================= + +subroutine sedi_uv (ks, ke, m1, dp, u, v) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in), dimension (ks:ke) :: m1, dp + + real, intent (inout), dimension (ks:ke) :: u, v + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + do k = ks + 1, ke + u (k) = (dp (k) * u (k) + m1 (k - 1) * u (k - 1)) / (dp (k) + m1 (k - 1)) + v (k) = (dp (k) * v (k) + m1 (k - 1) * v (k - 1)) / (dp (k) + m1 (k - 1)) + enddo + +end subroutine sedi_uv + +! ======================================================================= +! sedimentation of vertical momentum +! ======================================================================= + +subroutine sedi_w (ks, ke, m1, w, vt, dm) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in), dimension (ks:ke) :: m1, vt, dm + + real, intent (inout), dimension (ks:ke) :: w + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + w (ks) = w (ks) + m1 (ks) * vt (ks) / dm (ks) + do k = ks + 1, ke + w (k) = (dm (k) * w (k) + m1 (k - 1) * (w (k - 1) - vt (k - 1)) + m1 (k) * vt (k)) / & + (dm (k) + m1 (k - 1)) + enddo + +end subroutine sedi_w + +! ======================================================================= +! sedimentation of heat +! ======================================================================= + +subroutine sedi_heat (ks, ke, dm, m1, dz, tz, qv, ql, qr, qi, qs, qg, cw) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: cw + + real, intent (in), dimension (ks:ke) :: dm, m1, dz, qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real, dimension (ks:ke) :: dgz, cv0 + + do k = ks + 1, ke + dgz (k) = - 0.5 * grav * (dz (k - 1) + dz (k)) + cv0 (k) = dm (k) * (cv_air + qv (k) * cv_vap + (qr (k) + ql (k)) * c_liq + & + (qi (k) + qs (k) + qg (k)) * c_ice) + cw * (m1 (k) - m1 (k - 1)) + enddo + + do k = ks + 1, ke + tz (k) = (cv0 (k) * tz (k) + m1 (k - 1) * (cw * tz (k - 1) + dgz (k))) / & + (cv0 (k) + cw * m1 (k - 1)) + enddo + +end subroutine sedi_heat + +! ======================================================================= +! fast saturation adjustments +! ======================================================================= + +subroutine fast_sat_adj (dtm, is, ie, ks, ke, hydrostatic, consv_te, & + adj_vmr, te, dte, qv, ql, qr, qi, qs, qg, qa, qnl, qni, hs, delz, & + pt, delp, q_con, cappa, gsize, last_step, condensation, & + evaporation, deposition, sublimation, do_sat_adj) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: is, ie, ks, ke + + logical, intent (in) :: hydrostatic, last_step, consv_te, do_sat_adj + + real, intent (in) :: dtm + + real, intent (in), dimension (is:ie) :: hs, gsize + + real, intent (in), dimension (is:ie, ks:ke) :: qnl, qni + + real, intent (inout), dimension (is:ie, ks:ke) :: delp, delz, pt, te + real, intent (inout), dimension (is:ie, ks:ke) :: qv, ql, qr, qi, qs, qg, qa + + real, intent (inout), dimension (is:, ks:) :: q_con, cappa + + real, intent (inout), dimension (is:ie) :: condensation, deposition + real, intent (inout), dimension (is:ie) :: evaporation, sublimation + + real, intent (out), dimension (is:ie, ks:ke) :: adj_vmr + + real (kind = r8), intent (out), dimension (is:ie) :: dte + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real, dimension (is:ie, ks:ke) :: ua, va, wa, prefluxw, prefluxr, prefluxi, prefluxs, prefluxg + + real, dimension (is:ie) :: water, rain, ice, snow, graupel + + real, dimension (is:ie, ks:ke) :: pcw, edw, oew, rrw, tvw + real, dimension (is:ie, ks:ke) :: pci, edi, oei, rri, tvi + real, dimension (is:ie, ks:ke) :: pcr, edr, oer, rrr, tvr + real, dimension (is:ie, ks:ke) :: pcs, eds, oes, rrs, tvs + real, dimension (is:ie, ks:ke) :: pcg, edg, oeg, rrg, tvg + + ! ----------------------------------------------------------------------- + ! initialization + ! ----------------------------------------------------------------------- + + ua = 0.0 + va = 0.0 + wa = 0.0 + + water = 0.0 + rain = 0.0 + ice = 0.0 + snow = 0.0 + graupel = 0.0 + + prefluxw = 0.0 + prefluxr = 0.0 + prefluxi = 0.0 + prefluxs = 0.0 + prefluxg = 0.0 + + ! ----------------------------------------------------------------------- + ! major cloud microphysics driver + ! ----------------------------------------------------------------------- + + call mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, & + qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, & + gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, pcw, edw, oew, rrw, tvw, & + pci, edi, oei, rri, tvi, pcr, edr, oer, rrr, tvr, pcs, eds, oes, rrs, tvs, & + pcg, edg, oeg, rrg, tvg, prefluxw, prefluxr, prefluxi, & + prefluxs, prefluxg, condensation, deposition, evaporation, sublimation, & + last_step, .true., do_sat_adj, .false.) + +end subroutine fast_sat_adj + +! ======================================================================= +! rain freezing to form graupel, simple version +! ======================================================================= + +subroutine pgfr_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, sink, fac_r2g + + fac_r2g = 1. - exp (- dts / tau_r2g) + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .lt. 0. .and. qr (k) .gt. qcmin) then + + sink = (- tc * 0.025) ** 2 * qr (k) + sink = min (qr (k), sink, - fac_r2g * tc / icpk (k)) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., - sink, 0., 0., sink, te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pgfr_simp + +! ======================================================================= +! snow melting to form cloud water and rain, simple version +! ======================================================================= + +subroutine psmlt_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, tmp, sink, fac_smlt + + fac_smlt = 1. - exp (- dts / tau_smlt) + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .ge. 0. .and. qs (k) .gt. qcmin) then + + sink = (tc * 0.1) ** 2 * qs (k) + sink = min (qs (k), sink, fac_smlt * tc / icpk (k)) + tmp = min (sink, dim (qs_mlt, ql (k))) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., tmp, sink - tmp, 0., - sink, 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine psmlt_simp + +! ======================================================================= +! cloud water to rain autoconversion, simple version +! ======================================================================= + +subroutine praut_simp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, sink, fac_l2r + + fac_l2r = 1. - exp (- dts / tau_l2r) + + do k = ks, ke + + tc = tz (k) - t_wfr + + if (tc .gt. 0 .and. ql (k) .gt. ql0_max) then + + sink = fac_l2r * (ql (k) - ql0_max) + + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, sink, 0., 0., 0.) + + endif + + enddo + +end subroutine praut_simp + +! ======================================================================= +! cloud ice to snow autoconversion, simple version +! ======================================================================= + +subroutine psaut_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke) :: den + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, sink, fac_i2s, qim + + fac_i2s = 1. - exp (- dts / tau_i2s) + + do k = ks, ke + + tc = tz (k) - tice + + qim = qi0_max / den (k) + + if (tc .lt. 0. .and. qi (k) .gt. qim) then + + sink = fac_i2s * (qi (k) - qim) + + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., - sink, sink, 0.) + + endif + + enddo + +end subroutine psaut_simp + +! ======================================================================= +! cloud radii diagnosis built for gfdl cloud microphysics +! ======================================================================= + +subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, qa, & + qcw, qci, qcr, qcs, qcg, rew, rei, rer, res, reg, cld, cloud, snowd, & + cnvw, cnvi, cnvc) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: is, ie, ks, ke + + real, intent (in), dimension (is:ie) :: lsm, snowd + + real, intent (in), dimension (is:ie, ks:ke) :: delp, t, p, cloud + real, intent (in), dimension (is:ie, ks:ke) :: qv, qw, qi, qr, qs, qg, qa + + real, intent (in), dimension (is:ie, ks:ke), optional :: cnvw, cnvi, cnvc + + real, intent (inout), dimension (is:ie, ks:ke) :: qcw, qci, qcr, qcs, qcg + real, intent (inout), dimension (is:ie, ks:ke) :: rew, rei, rer, res, reg + real, intent (inout), dimension (is:ie, ks:ke) :: cld + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: i, k, ind + + real, dimension (is:ie, ks:ke) :: qmw, qmr, qmi, qms, qmg + + real :: dpg, rho, ccnw, mask, cor, tc, bw + real :: lambdaw, lambdar, lambdai, lambdas, lambdag, rei_fac + + real :: retab (138) = (/ & + 0.05000, 0.05000, 0.05000, 0.05000, 0.05000, 0.05000, & + 0.05500, 0.06000, 0.07000, 0.08000, 0.09000, 0.10000, & + 0.20000, 0.30000, 0.40000, 0.50000, 0.60000, 0.70000, & + 0.80000, 0.90000, 1.00000, 1.10000, 1.20000, 1.30000, & + 1.40000, 1.50000, 1.60000, 1.80000, 2.00000, 2.20000, & + 2.40000, 2.60000, 2.80000, 3.00000, 3.20000, 3.50000, & + 3.80000, 4.10000, 4.40000, 4.70000, 5.00000, 5.30000, & + 5.60000, 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, & + 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, & + 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, & + 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, & + 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, & + 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, & + 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, & + 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, & + 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, & + 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, & + 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, & + 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, & + 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, & + 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, & + 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, & + 205.728, 214.055, 222.694, 231.661, 240.971, 250.639 /) + + qmw = qw + qmi = qi + qmr = qr + qms = qs + qmg = qg + cld = cloud + + ! ----------------------------------------------------------------------- + ! merge convective cloud to total cloud + ! ----------------------------------------------------------------------- + + if (present (cnvw)) then + qmw = qmw + cnvw + endif + if (present (cnvi)) then + qmi = qmi + cnvi + endif + if (present (cnvc)) then + cld = cnvc + (1 - cnvc) * cld + endif + + ! ----------------------------------------------------------------------- + ! combine liquid and solid phases + ! ----------------------------------------------------------------------- + + if (liq_ice_combine) then + do i = is, ie + do k = ks, ke + qmw (i, k) = qmw (i, k) + qmr (i, k) + qmr (i, k) = 0.0 + qmi (i, k) = qmi (i, k) + qms (i, k) + qmg (i, k) + qms (i, k) = 0.0 + qmg (i, k) = 0.0 + enddo + enddo + endif + + ! ----------------------------------------------------------------------- + ! combine snow and graupel + ! ----------------------------------------------------------------------- + + if (snow_grauple_combine) then + do i = is, ie + do k = ks, ke + qms (i, k) = qms (i, k) + qmg (i, k) + qmg (i, k) = 0.0 + enddo + enddo + endif + + + do i = is, ie + + do k = ks, ke + + qmw (i, k) = max (qmw (i, k), qcmin) + qmi (i, k) = max (qmi (i, k), qcmin) + qmr (i, k) = max (qmr (i, k), qcmin) + qms (i, k) = max (qms (i, k), qcmin) + qmg (i, k) = max (qmg (i, k), qcmin) + + cld (i, k) = min (max (cld (i, k), 0.0), 1.0) + + mask = min (max (lsm (i), 0.0), 2.0) + + dpg = abs (delp (i, k)) / grav + rho = p (i, k) / (rdgas * t (i, k) * (1. + zvir * qv (i, k))) + + tc = t (i, k) - tice + + if (rewflag .eq. 1) then + + ! ----------------------------------------------------------------------- + ! cloud water (Martin et al. 1994) + ! ----------------------------------------------------------------------- + + if (prog_ccn) then + ! boucher and lohmann (1995) + ccnw = (1.0 - abs (mask - 1.0)) * & + (10. ** 2.24 * (qa (i, k) * rho * 1.e9) ** 0.257) + & + abs (mask - 1.0) * & + (10. ** 2.06 * (qa (i, k) * rho * 1.e9) ** 0.48) + else + ccnw = ccn_o * abs (mask - 1.0) + ccn_l * (1.0 - abs (mask - 1.0)) + endif + + if (qmw (i, k) .gt. qcmin) then + qcw (i, k) = dpg * qmw (i, k) * 1.0e3 + rew (i, k) = exp (1.0 / 3.0 * log ((3.0 * qmw (i, k) * rho) / & + (4.0 * pi * rhow * ccnw))) * 1.0e4 + rew (i, k) = max (rewmin, min (rewmax, rew (i, k))) + else + qcw (i, k) = 0.0 + rew (i, k) = rewmin + endif + + endif + + if (rewflag .eq. 2) then + + ! ----------------------------------------------------------------------- + ! cloud water (Martin et al. 1994, gfdl revision) + ! ----------------------------------------------------------------------- + + if (prog_ccn) then + ! boucher and lohmann (1995) + ccnw = (1.0 - abs (mask - 1.0)) * & + (10. ** 2.24 * (qa (i, k) * rho * 1.e9) ** 0.257) + & + abs (mask - 1.0) * & + (10. ** 2.06 * (qa (i, k) * rho * 1.e9) ** 0.48) + else + ccnw = 1.077 * ccn_o * abs (mask - 1.0) + 1.143 * ccn_l * (1.0 - abs (mask - 1.0)) + endif + + if (qmw (i, k) .gt. qcmin) then + qcw (i, k) = dpg * qmw (i, k) * 1.0e3 + rew (i, k) = exp (1.0 / 3.0 * log ((3.0 * qmw (i, k) * rho) / & + (4.0 * pi * rhow * ccnw))) * 1.0e4 + rew (i, k) = max (rewmin, min (rewmax, rew (i, k))) + else + qcw (i, k) = 0.0 + rew (i, k) = rewmin + endif + + endif + + if (rewflag .eq. 3) then + + ! ----------------------------------------------------------------------- + ! cloud water (Kiehl et al. 1994) + ! ----------------------------------------------------------------------- + + if (qmw (i, k) .gt. qcmin) then + qcw (i, k) = dpg * qmw (i, k) * 1.0e3 + rew (i, k) = 14.0 * abs (mask - 1.0) + & + (8.0 + (14.0 - 8.0) * min (1.0, max (0.0, - tc / 30.0))) * & + (1.0 - abs (mask - 1.0)) + rew (i, k) = rew (i, k) + (14.0 - rew (i, k)) * & + min (1.0, max (0.0, snowd (i) / 1000.0)) + rew (i, k) = max (rewmin, min (rewmax, rew (i, k))) + else + qcw (i, k) = 0.0 + rew (i, k) = rewmin + endif + + endif + + if (rewflag .eq. 4) then + + ! ----------------------------------------------------------------------- + ! cloud water derived from PSD + ! ----------------------------------------------------------------------- + + if (qmw (i, k) .gt. qcmin) then + qcw (i, k) = dpg * qmw (i, k) * 1.0e3 + call cal_pc_ed_oe_rr_tv (qmw (i, k), rho, blinw, muw, & + eda = edaw, edb = edbw, ed = rew (i, k)) + rew (i, k) = rewfac * 0.5 * rew (i, k) * 1.0e6 + rew (i, k) = max (rewmin, min (rewmax, rew (i, k))) + else + qcw (i, k) = 0.0 + rew (i, k) = rewmin + endif + + endif + + if (reiflag .eq. 1) then + + ! ----------------------------------------------------------------------- + ! cloud ice (Heymsfield and Mcfarquhar 1996) + ! ----------------------------------------------------------------------- + + if (qmi (i, k) .gt. qcmin) then + qci (i, k) = dpg * qmi (i, k) * 1.0e3 + rei_fac = log (1.0e3 * qmi (i, k) * rho) + if (tc .lt. - 50) then + rei (i, k) = beta / 9.917 * exp (0.109 * rei_fac) * 1.0e3 + elseif (tc .lt. - 40) then + rei (i, k) = beta / 9.337 * exp (0.080 * rei_fac) * 1.0e3 + elseif (tc .lt. - 30) then + rei (i, k) = beta / 9.208 * exp (0.055 * rei_fac) * 1.0e3 + else + rei (i, k) = beta / 9.387 * exp (0.031 * rei_fac) * 1.0e3 + endif + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + qci (i, k) = 0.0 + rei (i, k) = reimin + endif + + endif + + if (reiflag .eq. 2) then + + ! ----------------------------------------------------------------------- + ! cloud ice (Donner et al. 1997) + ! ----------------------------------------------------------------------- + + if (qmi (i, k) .gt. qcmin) then + qci (i, k) = dpg * qmi (i, k) * 1.0e3 + if (tc .le. - 55) then + rei (i, k) = 15.41627 + elseif (tc .le. - 50) then + rei (i, k) = 16.60895 + elseif (tc .le. - 45) then + rei (i, k) = 32.89967 + elseif (tc .le. - 40) then + rei (i, k) = 35.29989 + elseif (tc .le. - 35) then + rei (i, k) = 55.65818 + elseif (tc .le. - 30) then + rei (i, k) = 85.19071 + elseif (tc .le. - 25) then + rei (i, k) = 72.35392 + else + rei (i, k) = 92.46298 + endif + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + qci (i, k) = 0.0 + rei (i, k) = reimin + endif + + endif + + if (reiflag .eq. 3) then + + ! ----------------------------------------------------------------------- + ! cloud ice (Fu 2007) + ! ----------------------------------------------------------------------- + + if (qmi (i, k) .gt. qcmin) then + qci (i, k) = dpg * qmi (i, k) * 1.0e3 + rei (i, k) = 47.05 + tc * (0.6624 + 0.001741 * tc) + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + qci (i, k) = 0.0 + rei (i, k) = reimin + endif + + endif + + if (reiflag .eq. 4) then + + ! ----------------------------------------------------------------------- + ! cloud ice (Kristjansson et al. 2000) + ! ----------------------------------------------------------------------- + + if (qmi (i, k) .gt. qcmin) then + qci (i, k) = dpg * qmi (i, k) * 1.0e3 + ind = min (max (int (t (i, k) - 136.0), 44), 138 - 1) + cor = t (i, k) - int (t (i, k)) + rei (i, k) = retab (ind) * (1. - cor) + retab (ind + 1) * cor + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + qci (i, k) = 0.0 + rei (i, k) = reimin + endif + + endif + + if (reiflag .eq. 5) then + + ! ----------------------------------------------------------------------- + ! cloud ice (Wyser 1998) + ! ----------------------------------------------------------------------- + + if (qmi (i, k) .gt. qcmin) then + qci (i, k) = dpg * qmi (i, k) * 1.0e3 + bw = - 2. + 1.e-3 * log10 (rho * qmi (i, k) / 50.e-3) * & + exp (1.5 * log (max (1.e-10, - tc))) + rei (i, k) = 377.4 + bw * (203.3 + bw * (37.91 + 2.3696 * bw)) + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + qci (i, k) = 0.0 + rei (i, k) = reimin + endif + + endif + + if (reiflag .eq. 6) then + + ! ----------------------------------------------------------------------- + ! cloud ice (Sun and Rikus 1999, Sun 2001) + ! ----------------------------------------------------------------------- + + if (qmi (i, k) .gt. qcmin) then + qci (i, k) = dpg * qmi (i, k) * 1.0e3 + rei_fac = log (1.0e3 * qmi (i, k) * rho) + rei (i, k) = 45.8966 * exp (0.2214 * rei_fac) + & + 0.7957 * exp (0.2535 * rei_fac) * (tc + 190.0) + rei (i, k) = (1.2351 + 0.0105 * tc) * rei (i, k) + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + qci (i, k) = 0.0 + rei (i, k) = reimin + endif + + endif + + if (reiflag .eq. 7) then + + ! ----------------------------------------------------------------------- + ! cloud ice derived from PSD + ! ----------------------------------------------------------------------- + + if (qmi (i, k) .gt. qcmin) then + qci (i, k) = dpg * qmi (i, k) * 1.0e3 + call cal_pc_ed_oe_rr_tv (qmi (i, k), rho, blini, mui, & + eda = edai, edb = edbi, ed = rei (i, k)) + rei (i, k) = reifac * 0.5 * rei (i, k) * 1.0e6 + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + qci (i, k) = 0.0 + rei (i, k) = reimin + endif + + endif + + if (rerflag .eq. 1) then + + ! ----------------------------------------------------------------------- + ! rain derived from PSD + ! ----------------------------------------------------------------------- + + if (qmr (i, k) .gt. qcmin) then + qcr (i, k) = dpg * qmr (i, k) * 1.0e3 + call cal_pc_ed_oe_rr_tv (qmr (i, k), rho, blinr, mur, & + eda = edar, edb = edbr, ed = rer (i, k)) + rer (i, k) = 0.5 * rer (i, k) * 1.0e6 + rer (i, k) = max (rermin, min (rermax, rer (i, k))) + else + qcr (i, k) = 0.0 + rer (i, k) = rermin + endif + + endif + + if (resflag .eq. 1) then + + ! ----------------------------------------------------------------------- + ! snow derived from PSD + ! ----------------------------------------------------------------------- + + if (qms (i, k) .gt. qcmin) then + qcs (i, k) = dpg * qms (i, k) * 1.0e3 + call cal_pc_ed_oe_rr_tv (qms (i, k), rho, blins, mus, & + eda = edas, edb = edbs, ed = res (i, k)) + res (i, k) = 0.5 * res (i, k) * 1.0e6 + res (i, k) = max (resmin, min (resmax, res (i, k))) + else + qcs (i, k) = 0.0 + res (i, k) = resmin + endif + + endif + + if (regflag .eq. 1) then + + ! ----------------------------------------------------------------------- + ! graupel derived from PSD + ! ----------------------------------------------------------------------- + + if (qmg (i, k) .gt. qcmin) then + qcg (i, k) = dpg * qmg (i, k) * 1.0e3 + if (do_hail) then + call cal_pc_ed_oe_rr_tv (qmg (i, k), rho, blinh, muh, & + eda = edah, edb = edbh, ed = reg (i, k)) + else + call cal_pc_ed_oe_rr_tv (qmg (i, k), rho, bling, mug, & + eda = edag, edb = edbg, ed = reg (i, k)) + endif + reg (i, k) = 0.5 * reg (i, k) * 1.0e6 + reg (i, k) = max (regmin, min (regmax, reg (i, k))) + else + qcg (i, k) = 0.0 + reg (i, k) = regmin + endif + + endif + + enddo + + enddo + +end subroutine cld_eff_rad + +! ======================================================================= +! radar reflectivity +! ======================================================================= + +subroutine rad_ref (is, ie, js, je, isd, ied, jsd, jed, q, pt, delp, peln, & + delz, dbz, maxdbz, allmax, npz, ncnst, hydrostatic, zvir, & + do_inline_mp, sphum, liq_wat, ice_wat, rainwat, snowwat, graupel, mp_top) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + logical, intent (in) :: hydrostatic, do_inline_mp + + integer, intent (in) :: is, ie, js, je, isd, ied, jsd, jed + integer, intent (in) :: npz, ncnst, mp_top + integer, intent (in) :: sphum, liq_wat, ice_wat, rainwat, snowwat, graupel + + real, intent (in) :: zvir + + real, intent (in), dimension (is:, js:, 1:) :: delz + + real, intent (in), dimension (isd:ied, jsd:jed, npz) :: pt, delp + + real, intent (in), dimension (isd:ied, jsd:jed, npz, ncnst) :: q + + real, intent (in), dimension (is:ie, npz + 1, js:je) :: peln + + real, intent (out) :: allmax + + real, intent (out), dimension (is:ie, js:je) :: maxdbz + + real, intent (out), dimension (is:ie, js:je, npz) :: dbz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: i, j, k + + real, parameter :: alpha = 0.224, mp_const = 200 * exp (1.6 * log (3.6e6)) + + real (kind = r8) :: qden, z_e + real :: fac_r, fac_s, fac_g + + real, dimension (npz) :: den, denfac, qmr, qms, qmg, vtr, vts, vtg + + ! ----------------------------------------------------------------------- + ! return if the microphysics scheme doesn't include rain + ! ----------------------------------------------------------------------- + + if (rainwat .lt. 1) return + + ! ----------------------------------------------------------------------- + ! initialization + ! ----------------------------------------------------------------------- + + dbz = - 20. + maxdbz = - 20. + allmax = - 20. + + ! ----------------------------------------------------------------------- + ! calculate radar reflectivity + ! ----------------------------------------------------------------------- + + do j = js, je + do i = is, ie + + ! ----------------------------------------------------------------------- + ! air density + ! ----------------------------------------------------------------------- + + do k = 1, npz + if (hydrostatic) then + den (k) = delp (i, j, k) / ((peln (i, k + 1, j) - peln (i, k, j)) * & + rdgas * pt (i, j, k) * (1. + zvir * q (i, j, k, sphum))) + else + den (k) = - delp (i, j, k) / (grav * delz (i, j, k)) + endif + qmr (k) = max (qcmin, q (i, j, k, rainwat)) + qms (k) = max (qcmin, q (i, j, k, snowwat)) + qmg (k) = max (qcmin, q (i, j, k, graupel)) + enddo + + do k = 1, npz + denfac (k) = sqrt (den (npz) / den (k)) + enddo + + ! ----------------------------------------------------------------------- + ! fall speed + ! ----------------------------------------------------------------------- + + if (radr_flag .eq. 3) then + call term_rsg (1, npz, qmr, den, denfac, vr_fac, blinr, & + mur, tvar, tvbr, vr_max, const_vr, vtr) + vtr = vtr / rhor + endif + + if (rads_flag .eq. 3) then + call term_rsg (1, npz, qms, den, denfac, vs_fac, blins, & + mus, tvas, tvbs, vs_max, const_vs, vts) + vts = vts / rhos + endif + + if (radg_flag .eq. 3) then + if (do_hail .and. .not. do_inline_mp) then + call term_rsg (1, npz, qmg, den, denfac, vg_fac, blinh, & + muh, tvah, tvbh, vg_max, const_vg, vtg) + vtg = vtg / rhoh + else + call term_rsg (1, npz, qmg, den, denfac, vg_fac, bling, & + mug, tvag, tvbg, vg_max, const_vg, vtg) + vtg = vtg / rhog + endif + endif + + ! ----------------------------------------------------------------------- + ! radar reflectivity + ! ----------------------------------------------------------------------- + + do k = mp_top + 1, npz + z_e = 0. + + if (rainwat .gt. 0) then + qden = den (k) * qmr (k) + if (qmr (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qmr (k), den (k), blinr, mur, & + rra = rrar, rrb = rrbr, rr = fac_r) + else + fac_r = 0.0 + endif + if (radr_flag .eq. 1 .or. radr_flag .eq. 2) then + z_e = z_e + fac_r * 1.e18 + endif + if (radr_flag .eq. 3) then + z_e = z_e + mp_const * exp (1.6 * log (qden * vtr (k))) + endif + endif + + if (snowwat .gt. 0) then + qden = den (k) * qms (k) + if (qms (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qms (k), den (k), blins, mus, & + rra = rras, rrb = rrbs, rr = fac_s) + else + fac_s = 0.0 + endif + if (rads_flag .eq. 1) then + if (pt (i, j, k) .lt. tice) then + z_e = z_e + fac_s * 1.e18 * alpha * (rhos / rhor) ** 2 + else + z_e = z_e + fac_s * 1.e18 * alpha * (rhos / rhor) ** 2 / alpha + endif + endif + if (rads_flag .eq. 2) then + if (pt (i, j, k) .lt. tice) then + z_e = z_e + fac_s * 1.e18 * alpha * (rhos / rhoi) ** 2 + else + z_e = z_e + fac_s * 1.e18 + endif + endif + if (rads_flag .eq. 3) then + z_e = z_e + mp_const * exp (1.6 * log (qden * vts (k))) + endif + endif + + if (graupel .gt. 0) then + qden = den (k) * qmg (k) + if (do_hail .and. .not. do_inline_mp) then + if (qmg (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qmg (k), den (k), blinh, muh, & + rra = rrah, rrb = rrbh, rr = fac_g) + else + fac_g = 0.0 + endif + if (radg_flag .eq. 1) then + if (pt (i, j, k) .lt. tice) then + z_e = z_e + fac_g * 1.e18 * alpha * (rhoh / rhor) ** 2 + else + z_e = z_e + fac_g * 1.e18 * alpha * (rhoh / rhor) ** 2 / alpha + endif + endif + if (radg_flag .eq. 2) then + z_e = z_e + fac_g * 1.e18 + endif + else + if (qmg (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qmg (k), den (k), bling, mug, & + rra = rrag, rrb = rrbg, rr = fac_g) + else + fac_g = 0.0 + endif + if (radg_flag .eq. 1) then + if (pt (i, j, k) .lt. tice) then + z_e = z_e + fac_g * 1.e18 * alpha * (rhog / rhor) ** 2 + else + z_e = z_e + fac_g * 1.e18 * alpha * (rhog / rhor) ** 2 / alpha + endif + endif + if (radg_flag .eq. 2) then + z_e = z_e + fac_g * 1.e18 + endif + endif + if (radg_flag .eq. 3) then + z_e = z_e + mp_const * exp (1.6 * log (qden * vtg (k))) + endif + endif + + dbz (i, j, k) = 10. * log10 (max (0.01, z_e)) + enddo + + do k = mp_top + 1, npz + maxdbz (i, j) = max (dbz (i, j, k), maxdbz (i, j)) + enddo + + allmax = max (maxdbz (i, j), allmax) + + enddo + enddo + +end subroutine rad_ref + +! ======================================================================= +! moist heat capacity, 3 input variables +! ======================================================================= + +function mhc3 (qv, q_liq, q_sol) + + implicit none + + real (kind = r8) :: mhc3 + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: qv, q_liq, q_sol + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + mhc3 = one_r8 + qv * c1_vap + q_liq * c1_liq + q_sol * c1_ice + +end function mhc3 + +! ======================================================================= +! moist heat capacity, 4 input variables +! ======================================================================= + +function mhc4 (qd, qv, q_liq, q_sol) + + implicit none + + real (kind = r8) :: mhc4 + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: qv, q_liq, q_sol + + real (kind = r8), intent (in) :: qd + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + mhc4 = qd + qv * c1_vap + q_liq * c1_liq + q_sol * c1_ice + +end function mhc4 + +! ======================================================================= +! moist heat capacity, 6 input variables +! ======================================================================= + +function mhc6 (qv, ql, qr, qi, qs, qg) + + implicit none + + real (kind = r8) :: mhc6 + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: qv, ql, qr, qi, qs, qg + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real :: q_liq, q_sol + + q_liq = ql + qr + q_sol = qi + qs + qg + mhc6 = mhc (qv, q_liq, q_sol) + +end function mhc6 + +! ======================================================================= +! moist total energy +! ======================================================================= + +function mte (qv, ql, qr, qi, qs, qg, tk, dp, moist_q) + + implicit none + + real (kind = r8) :: mte + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + logical, intent (in) :: moist_q + + real, intent (in) :: qv, ql, qr, qi, qs, qg, dp + + real (kind = r8), intent (in) :: tk + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real :: q_liq, q_sol, q_cond + + real (kind = r8) :: cvm, con_r8 + + q_liq = ql + qr + q_sol = qi + qs + qg + q_cond = q_liq + q_sol + con_r8 = one_r8 - (qv + q_cond) + if (moist_q) then + cvm = mhc (con_r8, qv, q_liq, q_sol) + else + cvm = mhc (qv, q_liq, q_sol) + endif + mte = rgrav * cvm * c_air * tk * dp + +end function mte + +! ======================================================================= +! moist total energy and total water +! ======================================================================= + +subroutine mtetw (ks, ke, qv, ql, qr, qi, qs, qg, tz, ua, va, wa, delp, & + gsize, dte, vapor, water, rain, ice, snow, graupel, sen, stress, dts, & + te, tw, te_b, tw_b, moist_q, hydrostatic, te_loss) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + logical, intent (in) :: moist_q, hydrostatic + + real, intent (in) :: gsize, vapor, water, rain, ice, snow, graupel, dts, sen, stress + + real, intent (in), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ua, va, wa, delp + + real (kind = r8), intent (in) :: dte + + real (kind = r8), intent (in), dimension (ks:ke) :: tz + + real (kind = r8), intent (out) :: te_b, tw_b + + real (kind = r8), intent (out), optional :: te_loss + + real (kind = r8), intent (out), dimension (ks:ke) :: te, tw + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: q_cond + + real (kind = r8) :: con_r8 + + real, dimension (ks:ke) :: q_liq, q_sol + + real (kind = r8), dimension (ks:ke) :: cvm + + do k = ks, ke + q_liq (k) = ql (k) + qr (k) + q_sol (k) = qi (k) + qs (k) + qg (k) + q_cond = q_liq (k) + q_sol (k) + con_r8 = one_r8 - (qv (k) + q_cond) + if (moist_q) then + cvm (k) = mhc (con_r8, qv (k), q_liq (k), q_sol (k)) + else + cvm (k) = mhc (qv (k), q_liq (k), q_sol (k)) + endif + te (k) = (cvm (k) * tz (k) + lv00 * qv (k) - li00 * q_sol (k)) * c_air + if (hydrostatic) then + te (k) = te (k) + 0.5 * (ua (k) ** 2 + va (k) ** 2) + else + te (k) = te (k) + 0.5 * (ua (k) ** 2 + va (k) ** 2 + wa (k) ** 2) + endif + te (k) = rgrav * te (k) * delp (k) * gsize ** 2.0 + tw (k) = rgrav * (qv (k) + q_cond) * delp (k) * gsize ** 2.0 + enddo + te_b = (dte + (lv00 * c_air * vapor - li00 * c_air * (ice + snow + graupel)) * dts / 86400 + sen * dts + stress * dts) * gsize ** 2.0 + tw_b = (vapor + water + rain + ice + snow + graupel) * dts / 86400 * gsize ** 2.0 + + if (present (te_loss)) then + ! total energy change due to sedimentation and its heating + te_loss = dte * gsize ** 2.0 + endif + +end subroutine mtetw + +! ======================================================================= +! calculate heat capacities and latent heat coefficients +! ======================================================================= + +subroutine cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, & + cvm, te8, tz, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (in), dimension (ks:ke) :: tz + + real, intent (out), dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (out), dimension (ks:ke) :: cvm, te8 + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + do k = ks, ke + q_liq (k) = ql (k) + qr (k) + q_sol (k) = qi (k) + qs (k) + qg (k) + cvm (k) = mhc (qv (k), q_liq (k), q_sol (k)) + te8 (k) = cvm (k) * tz (k) + lv00 * qv (k) - li00 * q_sol (k) + lcpk (k) = (lv00 + d1_vap * tz (k)) / cvm (k) + icpk (k) = (li00 + d1_ice * tz (k)) / cvm (k) + tcpk (k) = (li20 + (d1_vap + d1_ice) * tz (k)) / cvm (k) + tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) + enddo + +end subroutine cal_mhc_lhc + +! ======================================================================= +! update hydrometeors +! ======================================================================= + +subroutine update_qq (qv, ql, qr, qi, qs, qg, dqv, dql, dqr, dqi, dqs, dqg) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: dqv, dql, dqr, dqi, dqs, dqg + + real, intent (inout) :: qv, ql, qr, qi, qs, qg + + qv = qv + dqv + ql = ql + dql + qr = qr + dqr + qi = qi + dqi + qs = qs + dqs + qg = qg + dqg + +end subroutine update_qq + +! ======================================================================= +! update hydrometeors and temperature +! ======================================================================= + +subroutine update_qt (qv, ql, qr, qi, qs, qg, dqv, dql, dqr, dqi, dqs, dqg, te8, & + cvm, tk, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: dqv, dql, dqr, dqi, dqs, dqg + + real (kind = r8), intent (in) :: te8 + + real, intent (inout) :: qv, ql, qr, qi, qs, qg + + real, intent (out) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (out) :: cvm, tk + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + qv = qv + dqv + ql = ql + dql + qr = qr + dqr + qi = qi + dqi + qs = qs + dqs + qg = qg + dqg + + cvm = mhc (qv, ql, qr, qi, qs, qg) + tk = (te8 - lv00 * qv + li00 * (qi + qs + qg)) / cvm + + lcpk = (lv00 + d1_vap * tk) / cvm + icpk = (li00 + d1_ice * tk) / cvm + tcpk = (li20 + (d1_vap + d1_ice) * tk) / cvm + tcp3 = lcpk + icpk * min (1., dim (tice, tk) / (tice - t_wfr)) + +end subroutine update_qt + +! ======================================================================= +! calculation of particle concentration (pc), effective diameter (ed), +! optical extinction (oe), radar reflectivity factor (rr), and +! mass-weighted terminal velocity (tv) +! ======================================================================= + +subroutine cal_pc_ed_oe_rr_tv (q, den, blin, mu, pca, pcb, pc, eda, edb, ed, & + oea, oeb, oe, rra, rrb, rr, tva, tvb, tv) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: blin, mu + + real, intent (in) :: q, den + + real (kind = r8), intent (in), optional :: pca, pcb, eda, edb, oea, oeb, rra, rrb, tva, tvb + + real, intent (out), optional :: pc, ed, oe, rr, tv + + if (present (pca) .and. present (pcb) .and. present (pc)) then + pc = pca / pcb * exp (mu / (mu + 3) * log (6 * den * q)) + endif + if (present (eda) .and. present (edb) .and. present (ed)) then + ed = eda / edb * exp (1. / (mu + 3) * log (6 * den * q)) + endif + if (present (oea) .and. present (oeb) .and. present (oe)) then + oe = oea / oeb * exp ((mu + 2) / (mu + 3) * log (6 * den * q)) + endif + if (present (rra) .and. present (rrb) .and. present (rr)) then + rr = rra / rrb * exp ((mu + 6) / (mu + 3) * log (6 * den * q)) + endif + if (present (tva) .and. present (tvb) .and. present (tv)) then + tv = tva / tvb * exp (blin / (mu + 3) * log (6 * den * q)) + endif + +end subroutine cal_pc_ed_oe_rr_tv + +! ======================================================================= +! prepare saturation water vapor pressure tables +! ======================================================================= + +subroutine qs_init + + implicit none + + integer :: i + + if (.not. tables_are_initialized) then + + allocate (table0 (length)) + allocate (table1 (length)) + allocate (table2 (length)) + allocate (table3 (length)) + allocate (table4 (length)) + + allocate (des0 (length)) + allocate (des1 (length)) + allocate (des2 (length)) + allocate (des3 (length)) + allocate (des4 (length)) + + call qs_table0 (length) + call qs_table1 (length) + call qs_table2 (length) + call qs_table3 (length) + call qs_table4 (length) + + do i = 1, length - 1 + des0 (i) = max (0., table0 (i + 1) - table0 (i)) + des1 (i) = max (0., table1 (i + 1) - table1 (i)) + des2 (i) = max (0., table2 (i + 1) - table2 (i)) + des3 (i) = max (0., table3 (i + 1) - table3 (i)) + des4 (i) = max (0., table4 (i + 1) - table4 (i)) + enddo + des0 (length) = des0 (length - 1) + des1 (length) = des1 (length - 1) + des2 (length) = des2 (length - 1) + des3 (length) = des3 (length - 1) + des4 (length) = des4 (length - 1) + + tables_are_initialized = .true. + + endif + +end subroutine qs_init + +! ======================================================================= +! saturation water vapor pressure table, core function +! ======================================================================= + +subroutine qs_table_core (n, n_blend, do_smith_table, table) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: n, n_blend + + logical, intent (in) :: do_smith_table + + real, intent (out), dimension (n) :: table + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: i + integer, parameter :: n_min = 1600 + + real (kind = r8) :: delt = 0.1 + real (kind = r8) :: tmin, tem, esh + real (kind = r8) :: wice, wh2o, fac0, fac1, fac2 + real (kind = r8) :: esbasw, tbasw, esbasi, a, b, c, d, e + real (kind = r8) :: esupc (n_blend) + + esbasw = 1013246.0 + tbasw = tice + 100. + esbasi = 6107.1 + tmin = tice - n_min * delt + + ! ----------------------------------------------------------------------- + ! compute es over ice between - (n_min * delt) deg C and 0 deg C + ! ----------------------------------------------------------------------- + + if (do_smith_table) then + do i = 1, n_min + tem = tmin + delt * real (i - 1) + a = - 9.09718 * (tice / tem - 1.) + b = - 3.56654 * log10 (tice / tem) + c = 0.876793 * (1. - tem / tice) + e = log10 (esbasi) + table (i) = 0.1 * exp ((a + b + c + e) * log (10.)) + enddo + else + do i = 1, n_min + tem = tmin + delt * real (i - 1) + fac0 = (tem - tice) / (tem * tice) + fac1 = fac0 * li2 + fac2 = (d2_ice * log (tem / tice) + fac1) / rvgas + table (i) = e00 * exp (fac2) + enddo + endif + + ! ----------------------------------------------------------------------- + ! compute es over water between - (n_blend * delt) deg C and [ (n - n_min - 1) * delt] deg C + ! ----------------------------------------------------------------------- + + if (do_smith_table) then + do i = 1, n - n_min + n_blend + tem = tice + delt * (real (i - 1) - n_blend) + a = - 7.90298 * (tbasw / tem - 1.) + b = 5.02808 * log10 (tbasw / tem) + c = - 1.3816e-7 * (exp ((1. - tem / tbasw) * 11.344 * log (10.)) - 1.) + d = 8.1328e-3 * (exp ((tbasw / tem - 1.) * (- 3.49149) * log (10.)) - 1.) + e = log10 (esbasw) + esh = 0.1 * exp ((a + b + c + d + e) * log (10.)) + if (i .le. n_blend) then + esupc (i) = esh + else + table (i + n_min - n_blend) = esh + endif + enddo + else + do i = 1, n - n_min + n_blend + tem = tice + delt * (real (i - 1) - n_blend) + fac0 = (tem - tice) / (tem * tice) + fac1 = fac0 * lv0 + fac2 = (dc_vap * log (tem / tice) + fac1) / rvgas + esh = e00 * exp (fac2) + if (i .le. n_blend) then + esupc (i) = esh + else + table (i + n_min - n_blend) = esh + endif + enddo + endif + + ! ----------------------------------------------------------------------- + ! derive blended es over ice and supercooled water between - (n_blend * delt) deg C and 0 deg C + ! ----------------------------------------------------------------------- + + do i = 1, n_blend + tem = tice + delt * (real (i - 1) - n_blend) + wice = 1.0 / (delt * n_blend) * (tice - tem) + wh2o = 1.0 / (delt * n_blend) * (tem - tice + delt * n_blend) + table (i + n_min - n_blend) = wice * table (i + n_min - n_blend) + wh2o * esupc (i) + enddo + +end subroutine qs_table_core + +! ======================================================================= +! saturation water vapor pressure table 0, water only +! useful for idealized experiments +! it can also be used in warm rain microphyscis only +! ======================================================================= + +subroutine qs_table0 (n) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: n + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: i + + real (kind = r8) :: delt = 0.1 + real (kind = r8) :: tmin, tem, fac0, fac1, fac2 + + tmin = tice - 160. + + ! ----------------------------------------------------------------------- + ! compute es over water only + ! ----------------------------------------------------------------------- + + do i = 1, n + tem = tmin + delt * real (i - 1) + fac0 = (tem - tice) / (tem * tice) + fac1 = fac0 * lv0 + fac2 = (dc_vap * log (tem / tice) + fac1) / rvgas + table0 (i) = e00 * exp (fac2) + enddo + +end subroutine qs_table0 + +! ======================================================================= +! saturation water vapor pressure table 1, water and ice +! blended between -20 deg C and 0 deg C +! the most realistic saturation water vapor pressure for the full temperature range +! ======================================================================= + +subroutine qs_table1 (n) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: n + + call qs_table_core (n, 200, .false., table1) + +end subroutine qs_table1 + +! ======================================================================= +! saturation water vapor pressure table 2, water and ice +! same as table 1, but the blending is replaced with smoothing around 0 deg C +! it is not designed for mixed-phase cloud microphysics +! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C) +! ======================================================================= + +subroutine qs_table2 (n) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: n + + call qs_table_core (n, 0, .false., table2) + +end subroutine qs_table2 + +! ======================================================================= +! saturation water vapor pressure table 3, water and ice +! blended between -20 deg C and 0 deg C +! the same as table 1, but from smithsonian meteorological tables page 350 +! ======================================================================= + +subroutine qs_table3 (n) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: n + + call qs_table_core (n, 200, .true., table3) + +end subroutine qs_table3 + +! ======================================================================= +! saturation water vapor pressure table 4, water and ice +! same as table 3, but the blending is replaced with smoothing around 0 deg C +! the same as table 2, but from smithsonian meteorological tables page 350 +! ======================================================================= + +subroutine qs_table4 (n) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: n + + call qs_table_core (n, 0, .true., table4) + +end subroutine qs_table4 + +! ======================================================================= +! compute the saturated water pressure, core function +! ======================================================================= + +function es_core (length, tk, table, des) + + implicit none + + real :: es_core + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: length + + real, intent (in) :: tk + + real, intent (in), dimension (length) :: table, des + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: it + + real :: ap1, tmin + + if (.not. tables_are_initialized) call qs_init + + tmin = tice - 160. + ap1 = 10. * dim (tk, tmin) + 1. + ap1 = min (2621., ap1) + it = ap1 + es_core = table (it) + (ap1 - it) * des (it) + +end function es_core + +! ======================================================================= +! compute the saturated specific humidity, core function +! ======================================================================= + +function qs_core (length, tk, den, dqdt, table, des) + + implicit none + + real :: qs_core + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: length + + real, intent (in) :: tk, den + + real, intent (in), dimension (length) :: table, des + + real, intent (out) :: dqdt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: it + + real :: ap1, tmin + + tmin = tice - 160. + ap1 = 10. * dim (tk, tmin) + 1. + ap1 = min (2621., ap1) + qs_core = es_core (length, tk, table, des) / (rvgas * tk * den) + it = ap1 - 0.5 + dqdt = 10. * (des (it) + (ap1 - it) * (des (it + 1) - des (it))) / (rvgas * tk * den) + +end function qs_core + +! ======================================================================= +! compute the saturated water pressure based on table 0, water only +! useful for idealized experiments +! it can also be used in warm rain microphyscis only +! ======================================================================= + +function wes_t (tk) + + implicit none + + real :: wes_t + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk + + wes_t = es_core (length, tk, table0, des0) + +end function wes_t + +! ======================================================================= +! compute the saturated water pressure based on table 1, water and ice +! the most realistic saturation water vapor pressure for the full temperature range +! ======================================================================= + +function mes_t (tk) + + implicit none + + real :: mes_t + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk + + mes_t = es_core (length, tk, table1, des1) + +end function mes_t + +! ======================================================================= +! compute the saturated water pressure based on table 2, water and ice +! it is not designed for mixed-phase cloud microphysics +! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C) +! ======================================================================= + +function ies_t (tk) + + implicit none + + real :: ies_t + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk + + ies_t = es_core (length, tk, table2, des2) + +end function ies_t + +! ======================================================================= +! compute the saturated specific humidity based on table 0, water only +! useful for idealized experiments +! it can also be used in warm rain microphyscis only +! ======================================================================= + +function wqs_trho (tk, den, dqdt) + + implicit none + + real :: wqs_trho + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk, den + + real, intent (out) :: dqdt + + wqs_trho = qs_core (length, tk, den, dqdt, table0, des0) + +end function wqs_trho + +! ======================================================================= +! compute the saturated specific humidity based on table 1, water and ice +! the most realistic saturation water vapor pressure for the full temperature range +! ======================================================================= + +function mqs_trho (tk, den, dqdt) + + implicit none + + real :: mqs_trho + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk, den + + real, intent (out) :: dqdt + + mqs_trho = qs_core (length, tk, den, dqdt, table1, des1) + +end function mqs_trho + +! ======================================================================= +! compute the saturated specific humidity based on table 2, water and ice +! it is not designed for mixed-phase cloud microphysics +! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C) +! ======================================================================= + +function iqs_trho (tk, den, dqdt) + + implicit none + + real :: iqs_trho + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk, den + + real, intent (out) :: dqdt + + iqs_trho = qs_core (length, tk, den, dqdt, table2, des2) + +end function iqs_trho + +! ======================================================================= +! compute the saturated specific humidity based on table 0, water only +! useful for idealized experiments +! it can also be used in warm rain microphyscis only +! ======================================================================= + +function wqs_ptqv (tk, pa, qv, dqdt) + + implicit none + + real :: wqs_ptqv + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk, pa, qv + + real, intent (out) :: dqdt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real :: den + + den = pa / (rdgas * tk * (1. + zvir * qv)) + + wqs_ptqv = wqs (tk, den, dqdt) + +end function wqs_ptqv + +! ======================================================================= +! compute the saturated specific humidity based on table 1, water and ice +! the most realistic saturation water vapor pressure for the full temperature range +! ======================================================================= + +function mqs_ptqv (tk, pa, qv, dqdt) + + implicit none + + real :: mqs_ptqv + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk, pa, qv + + real, intent (out) :: dqdt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real :: den + + den = pa / (rdgas * tk * (1. + zvir * qv)) + + mqs_ptqv = mqs (tk, den, dqdt) + +end function mqs_ptqv + +! ======================================================================= +! compute the saturated specific humidity based on table 2, water and ice +! it is not designed for mixed-phase cloud microphysics +! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C) +! ======================================================================= + +function iqs_ptqv (tk, pa, qv, dqdt) + + implicit none + + real :: iqs_ptqv + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk, pa, qv + + real, intent (out) :: dqdt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real :: den + + den = pa / (rdgas * tk * (1. + zvir * qv)) + + iqs_ptqv = iqs (tk, den, dqdt) + +end function iqs_ptqv + +! ======================================================================= +! compute the saturated specific humidity based on table 1, water and ice +! the most realistic saturation water vapor pressure for the full temperature range +! it is the 3d version of "mqs" +! ======================================================================= + +subroutine mqs3d (im, km, ks, tk, pa, qv, qs, dqdt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: im, km, ks + + real, intent (in), dimension (im, ks:km) :: tk, pa, qv + + real, intent (out), dimension (im, ks:km) :: qs + + real, intent (out), dimension (im, ks:km), optional :: dqdt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: i, k + + real :: dqdt0 + + if (present (dqdt)) then + do k = ks, km + do i = 1, im + qs (i, k) = mqs (tk (i, k), pa (i, k), qv (i, k), dqdt (i, k)) + enddo + enddo + else + do k = ks, km + do i = 1, im + qs (i, k) = mqs (tk (i, k), pa (i, k), qv (i, k), dqdt0) + enddo + enddo + endif + +end subroutine mqs3d + +! ======================================================================= +! compute wet buld temperature, core function +! Knox et al. (2017) +! ======================================================================= + +function wet_bulb_core (qv, tk, den, lcp) + + implicit none + + real :: wet_bulb_core + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: qv, tk, den, lcp + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + logical :: do_adjust = .false. + + real :: factor = 1. / 3. + real :: qsat, tp, dqdt + + wet_bulb_core = tk + qsat = wqs (wet_bulb_core, den, dqdt) + tp = factor * (qsat - qv) / (1. + lcp * dqdt) * lcp + wet_bulb_core = wet_bulb_core - tp + + if (do_adjust .and. tp .gt. 0.0) then + qsat = wqs (wet_bulb_core, den, dqdt) + tp = (qsat - qv) / (1. + lcp * dqdt) * lcp + wet_bulb_core = wet_bulb_core - tp + endif + +end function wet_bulb_core + +! ======================================================================= +! compute wet buld temperature, dry air case +! ======================================================================= + +function wet_bulb_dry (qv, tk, den) + + implicit none + + real :: wet_bulb_dry + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: qv, tk, den + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real :: lcp + + lcp = hlv / cp_air + + wet_bulb_dry = wet_bulb_core (qv, tk, den, lcp) + +end function wet_bulb_dry + +! ======================================================================= +! compute wet buld temperature, moist air case +! ======================================================================= + +function wet_bulb_moist (qv, ql, qi, qr, qs, qg, tk, den) + + implicit none + + real :: wet_bulb_moist + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: qv, ql, qi, qr, qs, qg, tk, den + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real :: lcp, q_liq, q_sol + + real (kind = r8) :: cvm + + q_liq = ql + qr + q_sol = qi + qs + qg + cvm = mhc (qv, q_liq, q_sol) + lcp = (lv00 + d1_vap * tk) / cvm + + wet_bulb_moist = wet_bulb_core (qv, tk, den, lcp) + +end function wet_bulb_moist + +end module gfdl_cld_mp_mod diff --git a/gsmphys/noahmp_tables.f90 b/gsmphys/noahmp_tables.f90 index 5b984597..46b6f95b 100644 --- a/gsmphys/noahmp_tables.f90 +++ b/gsmphys/noahmp_tables.f90 @@ -1,3 +1,12 @@ +!> \file noahmp_tables.f90 +!! This file contains Fortran versions of the data tables included with NoahMP in mptable.tbl, soilparm.tbl, and genparm.tbl. + +!> \ingroup NoahMP_LSM +!! \brief Data from MPTABLE.TBL, SOILPARM.TBL, GENPARM.TBL for NoahMP +!! +!! Note that a subset of the data in the *.TBL files is represented in this file. For example, +!! only the data in the noah_mp_modis_parameters section of MPTABLE.TBL and the STAS section of +!! SOILPARM.TBL are included in this module. module noahmp_tables use machine , only : kind_phys diff --git a/gsmphys/physcons.f90 b/gsmphys/physcons.f90 index 4dea5853..9d6b656b 100644 --- a/gsmphys/physcons.f90 +++ b/gsmphys/physcons.f90 @@ -83,7 +83,7 @@ module physcons ! !> spec heat H2O gas (\f$J/kg/K\f$) real(kind=kind_phys),parameter:: con_cvap =1.8460e+3 !> spec heat H2O liq (\f$J/kg/K\f$) - real(kind=kind_phys),parameter:: con_cliq =4.1855e+3 + real(kind=kind_phys),parameter:: con_cliq =4.2180e+3 !> spec heat H2O ice (\f$J/kg/K\f$) real(kind=kind_phys),parameter:: con_csol =2.1060e+3 !> lat heat H2O cond (\f$J/kg\f$) diff --git a/gsmphys/radiation_astronomy.f b/gsmphys/radiation_astronomy.f index 88301b26..f66417f7 100644 --- a/gsmphys/radiation_astronomy.f +++ b/gsmphys/radiation_astronomy.f @@ -825,6 +825,7 @@ end subroutine solar !----------------------------------- subroutine coszmn & & ( xlon,sinlat,coslat,solhr, IM, me, daily_mean, & ! --- inputs + & fixed_sollat, sollat, & ! --- inputs & coszen, coszdg & ! --- outputs & ) @@ -841,6 +842,8 @@ subroutine coszmn & ! IM - num of grids in horizontal dimension ! ! me - print message control flag ! ! daily_mean - replace cosz with daily mean value ! +! fixed_sollat - fix solar latitude ! +! sollat - latitude the solar position fixed to (-90. to 90.) ! ! ! ! outputs: ! ! coszen(IM) - average of cosz for daytime only in sw call interval @@ -865,9 +868,9 @@ subroutine coszmn & integer, intent(in) :: IM, me real (kind=kind_phys), intent(in) :: sinlat(:), coslat(:), & - & xlon(:), solhr + & xlon(:), solhr, sollat - logical, intent(in) :: daily_mean + logical, intent(in) :: daily_mean, fixed_sollat ! --- outputs: real (kind=kind_phys), intent(out) :: coszen(:), coszdg(:) @@ -892,8 +895,13 @@ subroutine coszmn & cns = solang + float(it-1)*anginc + sollag do i = 1, IM - ss = sinlat(i) * sindec - cc = coslat(i) * cosdec + if (fixed_sollat) then + ss = sin(sollat * con_pi / 180.0) * sindec + cc = cos(sollat * con_pi / 180.0) * cosdec + else + ss = sinlat(i) * sindec + cc = coslat(i) * cosdec + endif if (it .eq. 1) then ! compute daily mean cosine solar zenith angle diff --git a/gsmphys/radiation_clouds.F b/gsmphys/radiation_clouds.F index 43f27caa..cadd15bb 100644 --- a/gsmphys/radiation_clouds.F +++ b/gsmphys/radiation_clouds.F @@ -254,7 +254,7 @@ module module_radiation_clouds ! real (kind=kind_phys), parameter :: gfac=1.0e5/con_g & &, gord=con_g/con_rd !> number of fields in cloud array - integer, parameter, public :: NF_CLDS = 9 + integer, parameter, public :: NF_CLDS = 11 !> number of cloud vertical domains integer, parameter, public :: NK_CLDS = 3 @@ -2445,7 +2445,7 @@ subroutine progcld6 & ! --- inputs: & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, & - & xlat,xlon,qw,qr,qi,qs,qg,slmsk,snowd,cldtot, & + & xlat,xlon,qw,qr,qi,qs,qg,qa,slmsk,snowd,cldtot, & & IX, NLAY, NLP1, & ! --- outputs: & clouds,clds,mtop,mbot & @@ -2524,7 +2524,7 @@ subroutine progcld6 & #ifdef fvGFS_2017 use gfdl_cloud_microphys_mod, only: cloud_diagnosis #else - use cld_eff_rad_mod, only: cld_eff_rad + use gfdl_cld_mp_mod, only: cld_eff_rad #endif ! implicit none @@ -2536,7 +2536,7 @@ subroutine progcld6 & & tlyr, tvly, qlyr, qstl, rhly, clw, cnvw, cnvc real (kind=kind_phys), dimension(:,:), intent(inout) :: & - & qw, qr, qi, qs, qg + & qw, qr, qi, qs, qg, qa real (kind=kind_phys), dimension(:,:), intent(inout) :: cldtot real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & @@ -2579,15 +2579,15 @@ subroutine progcld6 & #else #ifdef GFS_CLOUD_OVERLAP call cld_eff_rad (1, IX, 1, NLAY, slmsk, plyr*100, & - & abs(plvl(:,1:NLAY)-plvl(:,2:NLAY+1))*100, & - & tlyr, qw, qi, qr, qs, qg, cwp, cip, crp, & + & abs(plvl(:,1:NLAY)-plvl(:,2:NLAY+1))*100, tlyr, & + & qlyr, qw, qi, qr, qs, qg, qa, cwp, cip, crp, & & csp, cgp, rew, rei, rer, res, reg, cldtot, & & cldtot, snowd, cnvw=cnvw) cldcnv = cnvc #else call cld_eff_rad (1, IX, 1, NLAY, slmsk, plyr*100, & - & abs(plvl(:,1:NLAY)-plvl(:,2:NLAY+1))*100, & - & tlyr, qw, qi, qr, qs, qg, cwp, cip, crp, & + & abs(plvl(:,1:NLAY)-plvl(:,2:NLAY+1))*100, tlyr, & + & qlyr, qw, qi, qr, qs, qg, qa, cwp, cip, crp, & & csp, cgp, rew, rei, rer, res, reg, cldtot, & & cldtot, snowd, cnvw=cnvw, cnvc=cnvc) cldcnv = 0.0 @@ -2620,6 +2620,8 @@ subroutine progcld6 & clouds(i,k,7) = rer(i,k) clouds(i,k,8) = csp(i,k) clouds(i,k,9) = res(i,k) + clouds(i,k,10) = cgp(i,k) + clouds(i,k,11) = reg(i,k) enddo enddo diff --git a/gsmphys/radlw_main.f b/gsmphys/radlw_main.f index 69ac69f8..9892f07b 100644 --- a/gsmphys/radlw_main.f +++ b/gsmphys/radlw_main.f @@ -359,6 +359,7 @@ module module_radlw_main ! logical :: lhlwb = .false. logical :: lhlw0 = .false. logical :: lflxprf= .false. + logical :: ltau110= .false. ! --- those data will be set up only once by "rlwinit" @@ -456,7 +457,7 @@ subroutine lwrad & & clouds,icseed,aerosols,sfemis,sfgtmp, & & npts, nlay, nlp1, lprnt, & & hlwc,topflx,sfcflx, & ! --- outputs - & HLW0,HLWB,FLXPRF & !! --- optional + & HLW0,HLWB,FLXPRF,tau110 & !! --- optional & ) ! ==================== defination of variables ==================== ! @@ -663,6 +664,8 @@ subroutine lwrad & & intent(out) :: hlw0 type (proflw_type), dimension(npts,nlp1), optional, & & intent(out) :: flxprf + real (kind=kind_phys), dimension(npts,nlay), optional, & + & intent(out) :: tau110 ! --- locals: real (kind=kind_phys), dimension(0:nlp1) :: cldfrc @@ -715,8 +718,13 @@ subroutine lwrad & lhlwb = present ( hlwb ) lhlw0 = present ( hlw0 ) lflxprf= present ( flxprf ) + ltau110= present ( tau110 ) + if ( ltau110 ) then + tau110(:,:) = f_zero + endif + colamt(:,:) = f_zero !> -# Change random number seed value for each radiation invocation @@ -1045,6 +1053,11 @@ subroutine lwrad & taucld = f_zero endif + if ( ltau110 ) then + ! 11micron emissivity for COSP, Linjiong Zhou + tau110(iplon,:) = 1.0 - exp(- taucld(6,:)) + endif + ! if (lprnt) then ! print *,' after cldprop' ! print *,' clwp',clwp diff --git a/gsmphys/radsw_main.f b/gsmphys/radsw_main.f index 6897c02d..af32f84b 100644 --- a/gsmphys/radsw_main.f +++ b/gsmphys/radsw_main.f @@ -488,6 +488,7 @@ module module_radsw_main ! logical :: lhsw0 = .false. logical :: lflxprf= .false. logical :: lfdncmp= .false. + logical :: ltau067 = .false. !> those data will be set up only once by "rswinit" @@ -588,7 +589,7 @@ subroutine swrad & & cosz,solcon,NDAY,idxday, & & npts, nlay, nlp1, lprnt, & & hswc,topflx,sfcflx, & ! --- outputs - & HSW0,HSWB,FLXPRF,FDNCMP & ! --- optional + & HSW0,HSWB,FLXPRF,FDNCMP,tau067 & ! --- optional & ) ! ==================== defination of variables ==================== ! @@ -802,6 +803,8 @@ subroutine swrad & & intent(out) :: flxprf type (cmpfsw_type), dimension(npts), optional, & & intent(out) :: fdncmp + real (kind=kind_phys), dimension(npts,nlay), optional, & + & intent(out) :: tau067 ! --- locals: real (kind=kind_phys), dimension(nlay,ngptsw) :: cldfmc, & @@ -846,6 +849,7 @@ subroutine swrad & lhsw0 = present ( hsw0 ) lflxprf= present ( flxprf ) lfdncmp= present ( fdncmp ) + ltau067 = present ( tau067 ) !> -# Compute solar constant adjustment factor (s0fac) according to solcon. ! *** s0, the solar constant at toa in w/m**2, is hard-coded with @@ -876,6 +880,10 @@ subroutine swrad & hswb(:,:,:) = f_zero endif + if ( ltau067 ) then + tau067(:,:) = f_zero + endif + !> -# Change random number seed value for each radiation invocation !! (isubcsw =1 or 2). @@ -1150,6 +1158,11 @@ subroutine swrad & enddo endif ! end if_zcf1_block + if ( ltau067 ) then + ! 0.67micron optical depth for COSP, Linjiong Zhou + tau067(j1,:) = taucw(:,9) + endif + !> -# Call setcoef() to compute various coefficients needed in !! radiative transfer calculations. call setcoef & diff --git a/gsmphys/sflx.f b/gsmphys/sflx.f index bb816e9b..48cec341 100644 --- a/gsmphys/sflx.f +++ b/gsmphys/sflx.f @@ -187,9 +187,9 @@ subroutine sflx & real (kind=kind_phys), parameter :: cp = con_cp ! con_cp =1004.6 real (kind=kind_phys), parameter :: cp1 = 1004.5 ! con_cp in sflx, canres real (kind=kind_phys), parameter :: cp2 = 1004.0 ! con_cp in htr -! real (kind=kind_phys), parameter :: cph2o = con_cliq ! con_cliq=4.1855e+3 +! real (kind=kind_phys), parameter :: cph2o = con_cliq ! con_cliq=4.218e+3 real (kind=kind_phys), parameter :: cph2o1 = 4.218e+3 ! con_cliq in penman, snopac - real (kind=kind_phys), parameter :: cph2o2 = 4.2e6 ! con_cliq in hrt *unit diff! + real (kind=kind_phys), parameter :: cph2o2 = 4.218e6 ! con_cliq in hrt *unit diff! real (kind=kind_phys), parameter :: cpice = con_csol ! con_csol=2.106e+3 real (kind=kind_phys), parameter :: cpice1 = 2.106e6 ! con_csol in hrt *unit diff! ! real (kind=kind_phys), parameter :: sigma = con_sbc ! con_sbc=5.6704e-8 diff --git a/gsmphys/som_mlm.F90 b/gsmphys/som_mlm.F90 index b3509617..728c935e 100644 --- a/gsmphys/som_mlm.F90 +++ b/gsmphys/som_mlm.F90 @@ -37,9 +37,9 @@ module module_ocean ! ! real (kind=kind_phys) :: maxlat, width_buffer, minmld, & cpwater, rhowater, omega, grav - parameter(maxlat = 60.) ! determine the maximum latitude band for SOM/MLM + parameter(maxlat = 60.) ! determine the maximum latitude band for SOM/MLM parameter(minmld = 10.) ! minimum mixed layer depth - parameter(width_buffer = 15.) ! the width of a buffer band where SST is determined by both SOM/MLM + parameter(width_buffer = 15.) ! the width of a buffer band where SST is determined by both SOM/MLM ! and climatology (or climatology plus initial anomaly) parameter(cpwater = 4000.) parameter(rhowater = 1000.) @@ -68,14 +68,14 @@ module module_ocean ! real(kind=kind_phys) :: mld_restore_tscale = 1. ! restoring time scale for mld (day) real(kind=kind_phys) :: start_lat = -30. ! latitude starting from? Note that this value should not be smaller than -60. real(kind=kind_phys) :: end_lat = 30. ! latitude ending with? Note that this value should not be bigger than 60. - real(kind=kind_phys) :: tday1 = 3. ! - real(kind=kind_phys) :: tday2 = 10. ! - real(kind=kind_phys) :: sst_restore_tscale1= 3. ! restoring time scale for sst during the period from 1 to tday1 + real(kind=kind_phys) :: tday1 = 3. ! + real(kind=kind_phys) :: tday2 = 10. ! + real(kind=kind_phys) :: sst_restore_tscale1= 3. ! restoring time scale for sst during the period from 1 to tday1 real(kind=kind_phys) :: sst_restore_tscale2= 10. ! restoring time scale for sst for the period beyond tday2 - real(kind=kind_phys) :: mld_restore_tscale1= 3. ! restoring time scale for mld during the period from 1 to tday1 + real(kind=kind_phys) :: mld_restore_tscale1= 3. ! restoring time scale for mld during the period from 1 to tday1 real(kind=kind_phys) :: mld_restore_tscale2= 10. ! restoring time scale for mld for the period beyond tday2 ! beyond the latitude bands (start_lat:end_lat), using climatological SST or - ! climatological SST plus initial anomaly + ! climatological SST plus initial anomaly logical :: use_tvar_restore_sst = .false.! using time varying restoring time scale for sst logical :: use_tvar_restore_mld = .false.! using time varying restoring time scale for mld @@ -157,6 +157,13 @@ subroutine ocean_init & call abort endif + if (restore_method == 3 .and. .not. Model%use_ext_sst) then + write(6,*) ' som_mlm::ocean_init(): Cannot use restore_method == 3' + write(6,*) ' unless external SST provided ' + write(6,*) ' (use_ext_sst = .true.). Stop.' + call abort + endif + !--- write namelist to log file --- if (Model%me == Model%master) then write(logunit, *) "=============================================" @@ -212,19 +219,19 @@ subroutine update_ocean & hvml, & tmoml, & tmoml0 - - real (kind=kind_phys), dimension(:), intent(out) :: & + + real (kind=kind_phys), dimension(:), intent(out) :: & qflux_restore ! restoring flux for diagnosis purpose ! --- locals: real (kind=kind_phys) :: & - lat, mlcp, mldc, taut, taum, & + lat, mlcp, mldc, taut, taum, & alphat,alpham, bufzs, & bufzn, fcor, c1, c2, r1, r2 real (kind=kind_phys), dimension (size(tsfc,1)) :: tsfc1, tsfc2 real (kind=kind_phys), dimension (size(tsfc,1)) :: qsfc integer :: i - real (kind=kind_phys) :: & + real (kind=kind_phys) :: & tmlp, mldp, humlp, hvmlp, mldn, tmln, tmomln, fday, tem ! !===> ... begin here @@ -237,7 +244,7 @@ subroutine update_ocean & ! qsfc = 0. if (use_tvar_restore_sst) then - if (fday < tday1) then + if (fday < tday1) then taut = sst_restore_tscale1*86400. elseif (fday >= tday1 .and. fday < tday2 ) then tem = (sst_restore_tscale2 - sst_restore_tscale1)/(tday2-tday1) @@ -248,7 +255,7 @@ subroutine update_ocean & else taut = sst_restore_tscale*86400. endif - alphat = 1. + dtp/taut + alphat = 1. + dtp/taut ! if (use_tvar_restore_mld) then if (fday < tday1) then @@ -318,7 +325,7 @@ subroutine update_ocean & call abort endif - fcor = 2 * omega * sin (Grid%xlat(i)) + fcor = 2 * omega * sin (Grid%xlat(i)) if ( islmsk(i) ==0 ) then if (ocean_option == "SOM") then @@ -354,7 +361,7 @@ subroutine update_ocean & select case (ocean_option) case("SOM") if (use_qflux) then - tsfc1(i) = ts_som(i) + qsfc(i)/mlcp*dtp + tsfc1(i) = ts_som(i) + qsfc(i)/mlcp*dtp else tsfc1(i) = (ts_som(i) + qsfc(i)/mlcp*dtp + tsfc2(i)/taut*dtp ) / alphat endif @@ -384,7 +391,7 @@ subroutine update_ocean & c2 = min(1.0, abs((bufzn - lat) / (bufzn - end_lat)) ) ! r2 = (exp(c2**interp_order)-1.)/(exp(1.0)-1.) if (lat >= start_lat .and. lat<= end_lat ) then - tsfc(i) = tsfc1(i) + tsfc(i) = tsfc1(i) elseif (lat >= bufzs .and. lat < start_lat) then ! the first buffer zone ! tsfc(i) = c1 * tsfc1(i) + (1.-c1) * tsfc2(i) tsfc(i) = c1 * ts_som(i) + (1.-c1) * tsfc2(i) @@ -408,8 +415,8 @@ subroutine MLM1D(dt, F, taum, alpham, qsfc, taux, tauy, & IMPLICIT NONE !---------------------------------------------------------------- ! -! SUBROUTINE OCEANML CALCULATES THE SEA SURFACE TEMPERATURE -! FROM A SIMPLE OCEAN MIXED LAYER MODEL BASED ON +! SUBROUTINE OCEANML CALCULATES THE SEA SURFACE TEMPERATURE +! FROM A SIMPLE OCEAN MIXED LAYER MODEL BASED ON ! (Pollard, Rhines and Thompson (1973). ! !-- DT time step (second) @@ -417,14 +424,14 @@ subroutine MLM1D(dt, F, taum, alpham, qsfc, taux, tauy, & !-- taum MLD restoring time scale !-- alpham MLD restoring parameter !-- qsfc net surface heat flux -!-- taux wind stress at zonal direction -!-- tauy wind stress at meridional direction +!-- taux wind stress at zonal direction +!-- tauy wind stress at meridional direction !-- tml ocean mixed layer temperature (K) !-- tml0 ocean mixed layer temperature (K) at initial time or previous time step !-- tmoml top 200 m ocean mean temperature (K) at initial time or previous time step !-- H ocean mixed layer depth (m) !-- H0 ocean mixed layer depth (m) at initial time or nudged MLD toward climatology -!-- HC climatological or constant ocean mixed layer depth (m) +!-- HC climatological or constant ocean mixed layer depth (m) !-- huml ocean mixed layer u component of wind !-- hvml ocean mixed layer v component of wind ! @@ -477,7 +484,7 @@ subroutine MLM1D(dt, F, taum, alpham, qsfc, taux, tauy, & hv2=hv1+tauy2/rhowater*dt-fdt/2.*(hu2+hu1) endif ! consider the flux effect - A2 = A1+q*dt + A2 = A1+q*dt A3 = A1+q*dt - 0.5*Gam*h0**2 huml=hu2 @@ -495,14 +502,14 @@ subroutine MLM1D(dt, F, taum, alpham, qsfc, taux, tauy, & ! write(0,*) 'test0',h,hc,taum,alpham,dt if(do_mld_restore) then - h = (h + HC/taum*dt)/alpham + h = (h + HC/taum*dt)/alpham endif ! write(0,*) 'test1',h,hc,taum,alpham,dt ! limit to posit ive h change ! if (use_old_mlm) then -! if(h.lt.hold) h=hold +! if(h.lt.hold) h=hold ! else -! if(h.lt.hold) h=h0 +! if(h.lt.hold) h=h0 ! endif ! no change unless tml is warmer than layer mean temp tmol or tsk-5 (see omlinit) if(tml.ge.tmoml .and. h.ne.0.)then @@ -512,12 +519,12 @@ subroutine MLM1D(dt, F, taum, alpham, qsfc, taux, tauy, & if (use_old_mlm) then ! if MLD does not deepen, we only consider the surface heat flux effect if (h <= hold) then - tml=max(tml + q*dt/h, tmoml) + tml=max(tml + q*dt/h, tmoml) else - tml=max(tml0 - Gam*(h-h0) + 0.5*Gam*h + A2/h, tmoml) + tml=max(tml0 - Gam*(h-h0) + 0.5*Gam*h + A2/h, tmoml) endif else - tml=max(tml0 -0.5* Gam*(h-h0)*abs(h-h0)/h + A2/h, tmoml) + tml=max(tml0 -0.5* Gam*(h-h0)*abs(h-h0)/h + A2/h, tmoml) endif else tml=tmoml @@ -534,6 +541,6 @@ subroutine MLM1D(dt, F, taum, alpham, qsfc, taux, tauy, & end subroutine MLM1D - end module module_ocean + end module module_ocean !========================================= diff --git a/simple_coupler/coupler_main.F90 b/simple_coupler/coupler_main.F90 index 60f88d67..e886a5fb 100644 --- a/simple_coupler/coupler_main.F90 +++ b/simple_coupler/coupler_main.F90 @@ -513,4 +513,3 @@ end subroutine coupler_end !####################################################################### end program coupler_main -