diff --git a/bld/namelist_files/namelist_definition.xml b/bld/namelist_files/namelist_definition.xml index baaaffedc8..bc2660781d 100644 --- a/bld/namelist_files/namelist_definition.xml +++ b/bld/namelist_files/namelist_definition.xml @@ -7840,4 +7840,12 @@ Path to ocean file Default: path + + Random forest files + Random forest files + Random forest files + Random forest files + Random forest files + + diff --git a/bld/namelist_files/use_cases/ssp245_cam6_noresm.xml b/bld/namelist_files/use_cases/ssp245_cam6_noresm.xml new file mode 100644 index 0000000000..bf32f14e8f --- /dev/null +++ b/bld/namelist_files/use_cases/ssp245_cam6_noresm.xml @@ -0,0 +1,146 @@ + + + + + + 'atm/cam/solar/SolarForcingCMIP6_18491230-22991231_c171031.nc' + + + 'CHEM_LBC_FILE' + +atm/waccm/lb/LBC_2014-2500_CMIP6_SSP245_0p5degLat_GlobAnnAvg_c190301.nc +'SERIAL' +'CO2','CH4','N2O','CFC11eq','CFC12' + + + 'atm/cam/ozone_strataero' + 'ozone_strataero_WACCM_L70_zm5day_18500101-21010201_CMIP6histEnsAvg_SSP245_c190403.nc' + 'O3' + 'SERIAL' + + + 'atm/cam/tracer_cnst' + 'tracer_cnst_halons_3D_L70_1849-2101_CMIP6ensAvg_SSP2-4.5_c190403.nc' + 'O3','OH','NO3','HO2' + 'INTERP_MISSING_MONTHS' + '' + + + INTERP_MISSING_MONTHS + + + INTERP_MISSING_MONTHS + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_AX_anthrosurfALL_surface_2014-2301_0.9x1.25_version20190909.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_N_anthrosurfALL_surface_2014-2301_0.9x1.25_version20190909.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_OM_NI_anthrosurfALL_surface_2014-2301_0.9x1.25_version20190909.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO2_anthrosurfALL_surface_2014-2301_0.9x1.25_version20190909.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO4_PR_anthrosurfALL_surface_2014-2301_0.9x1.25_version20190909.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_AX_anthrosurfALL_surface_2014-2301_1.9x2.5_version20190909.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_N_anthrosurfALL_surface_2014-2301_1.9x2.5_version20190909.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_OM_NI_anthrosurfALL_surface_2014-2301_1.9x2.5_version20190909.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO2_anthrosurfALL_surface_2014-2301_1.9x2.5_version20190909.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO4_PR_anthrosurfALL_surface_2014-2301_1.9x2.5_version20190909.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_1849-2101_CMIP6ensAvg_SSP2-4.5_c190403.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_AX_airALL_vertical_2014-2301_0.9x1.25_version20190909.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_AX_anthroprofALL_vertical_2014-2301_0.9x1.25_version20190909.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_N_airALL_vertical_2014-2301_0.9x1.25_version20190909.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_N_anthroprofALL_vertical_2014-2301_0.9x1.25_version20190909.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_NI_bbALL_vertical_2014-2301_0.9x1.25_version20190909.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_OM_NI_airALL_vertical_2014-2301_0.9x1.25_version20190909.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_OM_NI_anthroprofALL_vertical_2014-2301_0.9x1.25_version20190909.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_OM_NI_bbALL_vertical_2014-2301_0.9x1.25_version20190909.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO2_airALL_vertical_2014-2301_0.9x1.25_version20190909.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO2_anthroprofALL_vertical_2014-2301_0.9x1.25_version20190909.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO2_bbALL_vertical_2014-2301_0.9x1.25_version20190909.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO2_volcALL_vertical_2014-2301_0.9x1.25_version20190909.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO4_PR_airALL_vertical_2014-2301_0.9x1.25_version20190909.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO4_PR_anthroprofALL_vertical_2014-2301_0.9x1.25_version20190909.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO4_PR_bbALL_vertical_2014-2301_0.9x1.25_version20190909.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO4_PR_volcALL_vertical_2014-2301_0.9x1.25_version20190909.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_1849-2101_CMIP6ensAvg_SSP2-4.5_c190403.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_AX_airALL_vertical_2014-2301_1.9x2.5_version20190909.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_AX_anthroprofALL_vertical_2014-2301_1.9x2.5_version20190909.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_N_airALL_vertical_2014-2301_1.9x2.5_version20190909.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_N_anthroprofALL_vertical_2014-2301_1.9x2.5_version20190909.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_NI_bbALL_vertical_2014-2301_1.9x2.5_version20190909.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_OM_NI_airALL_vertical_2014-2301_1.9x2.5_version20190909.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_OM_NI_anthroprofALL_vertical_2014-2301_1.9x2.5_version20190909.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_OM_NI_bbALL_vertical_2014-2301_1.9x2.5_version20190909.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO2_airALL_vertical_2014-2301_1.9x2.5_version20190909.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO2_anthroprofALL_vertical_2014-2301_1.9x2.5_version20190909.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO2_bbALL_vertical_2014-2301_1.9x2.5_version20190909.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO2_volcALL_vertical_2014-2301_1.9x2.5_version20190909.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO4_PR_airALL_vertical_2014-2301_1.9x2.5_version20190909.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO4_PR_anthroprofALL_vertical_2014-2301_1.9x2.5_version20190909.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO4_PR_bbALL_vertical_2014-2301_1.9x2.5_version20190909.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190909/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO4_PR_volcALL_vertical_2014-2301_1.9x2.5_version20190909.nc' + + + +0.286 +0.264 + + + .false. + .true. + .true. + .true. + .true. + .true. + + + .true. + + + .true. + + + 0.0200D0 + 0.0200D0 + + 8.0E-6 + 8.0E-6 + + + +5.5e-4 +5.0e-4 + + + .true. + + + 4 + + +0.90D0 + + +'isoprene = isoprene','monoterp = myrcene + sabinene + limonene+ carene_3 + ocimene_t_b + pinene_b + pinene_a' + + +noresm-only/atm/cam/chem/trop_mozart_aero/emis/soanucl/bvocgcmFV19_isopr_1850_2000_zero.nc +noresm-only/atm/cam/chem/trop_mozart_aero/emis/soanucl/bvocgcmFV19_monoterp_1850_2000_zero.nc + + +1850 + + + +'INTERP_MISSING_MONTHS' +atm/cam/volc +CMIP_CAM6_radiation_v3_reformatted.nc +'A:Q:H2O','N:O2:O2','N:CO2:CO2','N:ozone:O3','N:N2O:N2O','N:CH4:CH4','N:CFC11:CFC11','N:CFC12:CFC12' + + diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index a3568985d0..953c00af22 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -174,24 +174,24 @@ -offline_drv rad -phys cam5 -chem trop_mam_oslo - -chem trop_mam_oslo + -chem trop_mam_oslo_sec -chem trop_mam_oslo_sec - -chem trop_mam_oslo + -chem trop_mam_oslo_sec -chem trop_mam_oslo_sec - -chem trop_mam_oslo -cosp + -chem trop_mam_oslo_sec -cosp -chem trop_mam_oslo_sec -cosp -chem trop_mam_oslo_sec -cosp - -chem trop_mam_oslo -cosp + -chem trop_mam_oslo_sec -cosp -chem trop_mam_oslo_sec -cosp - -chem trop_mam_oslo -cosp + -chem trop_mam_oslo_sec -cosp -chem trop_mam_oslo_sec -cosp - -chem trop_mam_oslo -cosp + -chem trop_mam_oslo_sec -cosp -chem trop_mam_oslo_sec -cosp -chem trop_mam_oslo -phys cam5 -chem trop_mam_oslo -offline_dyn -chem trop_mam_oslo -offline_dyn - -chem trop_mam_oslo -offline_dyn + -chem trop_mam_oslo_sec -offline_dyn build_component_cam env_build.xml @@ -373,6 +373,7 @@ ssp126_cam6_noresm_frc2 ssp126_cam6_noresm_frc2ext ssp245_cam6_noresm_frc2 + ssp245_cam6_noresm ssp370_cam6_noresm_frc2 ssp370lowntcf_cam6_noresm_frc2 ssp370refghglowntcf_cam6_noresm_frc2 @@ -389,6 +390,7 @@ ssp245_cam6_noresm_covtwobli_frc2 ssp245_cam6_noresm_frc2 + ssp245_cam6_noresm_ghgonly_frc2 ssp245_cam6_noresm_natonly_frc2 ssp245_cam6_noresm_aeronly_frc2 @@ -450,26 +452,26 @@ flbc_list='CO2','CH4','N2O','CFC11eq','CFC12' ocean_filename='dms-hamocc-dow-taylor_chlor_a-lanaclim_N1850frc2_f09_tn14_20191012_1351-1380_cycle_version20200106.nc' - ocean_filename='dms-hamocc-dow-taylor_chlor_a-lanaclim_N1850_f19_tn14_20190621_1751-1780_cycle_version20190726.nc' + ocean_filename='dms-hamocc-dow-taylor_chlor_a-lanaclim_N1850_f19_tn14_Forces_230512_1751-1780_cycle_version20230512.nc' dms_cycle_year=1850 opom_cycle_year=1850 dms_source_type='CYCLICAL' opom_source_type='CYCLICAL' ocean_filename='dms-hamocc-dow-taylor_chlor_a-lanaclim_N1850frc2_f09_tn14_20191012_1351-1380_cycle_version20200106.nc' - ocean_filename='dms-hamocc-dow-taylor_chlor_a-lanaclim_N1850_f19_tn14_20190621_1751-1780_cycle_version20190726.nc' + ocean_filename='dms-hamocc-dow-taylor_chlor_a-lanaclim_N1850_f19_tn14_Forces_230512_1751-1780_cycle_version20230512.nc' dms_cycle_year=1850 opom_cycle_year=1850 dms_source_type='CYCLICAL' opom_source_type='CYCLICAL' - ocean_filename='dms-hamocc-dow-taylor_chlor_a-lanaclim_NHIST_f19_tn14_20190625_1849-2015_series_version20190726.nc' + ocean_filename='dms-hamocc-dow-taylor_chlor_a-lanaclim_NHIST_f19_tn14_Forces_230515_1849-2015_series_version20230515.nc' dms_source_type='INTERP_MISSING_MONTHS' opom_source_type='INTERP_MISSING_MONTHS' - ocean_filename='dms-hamocc-dow-taylor_chlor_a-lanaclim_NSSP370frc2_f19_tn14_20191014_2014-2101_series_version20200109.nc' + ocean_filename='dms-hamocc-dow-taylor_chlor_a-lanaclim_NHIST_f19_tn14_Forces_230515_1849-2015_series_version20230515.nc' dms_source_type='INTERP_MISSING_MONTHS' opom_source_type='INTERP_MISSING_MONTHS' @@ -487,6 +489,15 @@ opom_source_type='CYCLICAL' + + ocean_filename='dms-hamocc-dow-taylor_chlor_a-lanaclim_NHIST_f19_tn14_20190625_1985-2014_cycle_version20190726.nc' + dms_cycle_year=2000 + opom_cycle_year=2000 + dms_source_type='CYCLICAL' + opom_source_type='CYCLICAL' + + + co2vmr=1138.8e-6 co2vmr=1138.8e-6 @@ -552,6 +563,13 @@ lwkcomp9_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp9.out' lwkcomp10_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp10.out' + + forestfileALL='$DIN_LOC_ROOT/atm/cam/RaFSIP/forestALL.txt' + forestfileBRDS='$DIN_LOC_ROOT/atm/cam/RaFSIP/forestBRDS.txt' + forestfileBRHM='$DIN_LOC_ROOT/atm/cam/RaFSIP/forestBRHM.txt' + forestfileBR='$DIN_LOC_ROOT/atm/cam/RaFSIP/forestBR.txt' + forestfileBRwarm='$DIN_LOC_ROOT/atm/cam/RaFSIP/forestBRwarm.txt' + run_component_cam env_run.xml diff --git a/cime_config/config_compsets.xml b/cime_config/config_compsets.xml index 8e08e29d25..6414846005 100644 --- a/cime_config/config_compsets.xml +++ b/cime_config/config_compsets.xml @@ -261,6 +261,13 @@ + + NFSSP245norpddmsbc + SSP245_CAM60%NORESM%NORPDDMSBC_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + NFSSP245frc2norpibc_aeroxidonly SSP245_CAM60%NORESM%NORPIBC%AEROXIDONLY%FRC2_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV @@ -899,7 +906,7 @@ $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1x1_1850_2017_c180507.nc $DIN_LOC_ROOT/atm/cam/sst/"sst_HadOIBl_bc_48x96_1850_2017_c180507.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1.9x2.5_1850_2017_c180507.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1.9x2.5_1850_2017_c180507.nc $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.9x1.25_1850_2017_c180507.nc $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.47x0.63_1850_2017_c180507.nc $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.23x0.31_1850_2017_c180507.nc diff --git a/cime_config/usermods_dirs/NorESM_Forces_aer_cosp/SourceMods/src.cam/preprocessorDefinitions.h b/cime_config/usermods_dirs/NorESM_Forces_aer_cosp/SourceMods/src.cam/preprocessorDefinitions.h new file mode 100755 index 0000000000..3803258bdf --- /dev/null +++ b/cime_config/usermods_dirs/NorESM_Forces_aer_cosp/SourceMods/src.cam/preprocessorDefinitions.h @@ -0,0 +1,2 @@ +#define AEROCOM +#define AEROFFL diff --git a/cime_config/usermods_dirs/NorESM_Forces_aer_cosp/shell_commands b/cime_config/usermods_dirs/NorESM_Forces_aer_cosp/shell_commands new file mode 100644 index 0000000000..4c537047b9 --- /dev/null +++ b/cime_config/usermods_dirs/NorESM_Forces_aer_cosp/shell_commands @@ -0,0 +1,3 @@ +./xmlchange --append CAM_CONFIG_OPTS="-cppdefs '-DAEROCOM=1 -DAEROFFL=1'" + +./xmlchange --append CAM_CONFIG_OPTS="-cosp" diff --git a/cime_config/usermods_dirs/NorESM_Forces_aer_cosp/user_nl_cam b/cime_config/usermods_dirs/NorESM_Forces_aer_cosp/user_nl_cam new file mode 100644 index 0000000000..79cb98ce17 --- /dev/null +++ b/cime_config/usermods_dirs/NorESM_Forces_aer_cosp/user_nl_cam @@ -0,0 +1,19 @@ +nhtfrq = 0, -24, -6, -3, -1, 1, -24,-120,-240 + +mfilt = 1, 5, 20, 40, 120, 240, 365, 73, 365 + +ndens = 2, 2, 2, 2, 2, 2, 1, 1, 1 + +fincl1 = 'SST','TAUX','TAUY','TAUBLJX','TAUBLJY','BTAUNET','PRECC','PRECL','PRECT','FREQZM','PCONVB','PCONVT','PRECCDZM','Z700','Z500','Z200','Z300','Z100','Z050','U200','U850','V200','V850','T200','T500', 'T700','T1000','OMEGA500','OMEGA850','VTHzm','WTHzm','UVzm','UWzm','Uzm','Vzm','THzm','Wzm','dUzm','dVzm','dUazm','dVazm','dUfzm','U','V','T','Q','Z3','dU','dV','dUa','dVa','dUf','EFLX','PTTEND','IETEND_DME', 'PTTEND_DME','TFIX','EFIX','EP','QFLX','MEANPTOP','MEANTTOP','MEANTAU','TCLDAREA','RHREFHT','TREFMXAV','TREFMNAV','ozone','O3','TROP_P','TROP_T','TROP_Z','VT100' + + +fincl2 = 'PRECT:A','TREFHT:A', 'Z500:A' + + +&clubb_params_nl +clubb_gamma_coef = 0.290 + +µ_mg_nl +micro_mg_dcs = 3.5e-4 + +history_aerosol=.true. \ No newline at end of file diff --git a/cime_config/usermods_dirs/NorESM_Forces_lowoutput/user_nl_cam b/cime_config/usermods_dirs/NorESM_Forces_lowoutput/user_nl_cam new file mode 100644 index 0000000000..af6c224f1d --- /dev/null +++ b/cime_config/usermods_dirs/NorESM_Forces_lowoutput/user_nl_cam @@ -0,0 +1,17 @@ +nhtfrq = 0, -24, -6, -3, -1, 1, -24,-120,-240 + +mfilt = 1, 5, 20, 40, 120, 240, 365, 73, 365 + +ndens = 2, 2, 2, 2, 2, 2, 1, 1, 1 + +fincl1 = 'SST','TAUX','TAUY','TAUBLJX','TAUBLJY','BTAUNET','PRECC','PRECL','PRECT','FREQZM','PCONVB','PCONVT','PRECCDZM','Z700','Z500','Z200','Z300','Z100','Z050','U200','U850','V200','V850','T200','T500', 'T700','T1000','OMEGA500','OMEGA850','VTHzm','WTHzm','UVzm','UWzm','Uzm','Vzm','THzm','Wzm','dUzm','dVzm','dUazm','dVazm','dUfzm','U','V','T','Q','Z3','dU','dV','dUa','dVa','dUf','EFLX','PTTEND','IETEND_DME', 'PTTEND_DME','TFIX','EFIX','EP','QFLX','MEANPTOP','MEANTTOP','MEANTAU','TCLDAREA','RHREFHT','TREFMXAV','TREFMNAV','ozone','O3','TROP_P','TROP_T','TROP_Z','VT100' + + +fincl2 = 'PRECT:A','TREFHT:A', 'Z500:A' + + +&clubb_params_nl +clubb_gamma_coef = 0.290 + +µ_mg_nl +micro_mg_dcs = 3.5e-4 diff --git a/src/NorESM/clubb_intr.F90 b/src/NorESM/clubb_intr.F90 new file mode 100644 index 0000000000..f8f713a919 --- /dev/null +++ b/src/NorESM/clubb_intr.F90 @@ -0,0 +1,3679 @@ +module clubb_intr + + !----------------------------------------------------------------------------------------------------- ! + ! Module to interface CAM with Cloud Layers Unified by Bi-normals (CLUBB), developed ! + ! by the University of Wisconsin Milwaukee Group (UWM). ! + ! ! + ! CLUBB replaces the exisiting turbulence, shallow convection, and macrophysics in CAM5 ! + ! ! + ! Lastly, a implicit diffusion solver is called, and tendencies retrieved by ! + ! differencing the diffused and initial states. ! + ! ! + ! Calling sequence: ! + ! ! + !---------------------------Code history-------------------------------------------------------------- ! + ! Authors: P. Bogenschutz, C. Craig, A. Gettelman ! + ! ! + !----------------------------------------------------------------------------------------------------- ! + + use shr_kind_mod, only: r8=>shr_kind_r8 + use ppgrid, only: pver, pverp, pcols + use phys_control, only: phys_getopts + use physconst, only: rair, cpair, gravit, latvap, latice, zvir, rh2o, karman + use spmd_utils, only: masterproc + use constituents, only: pcnst, cnst_add + use pbl_utils, only: calc_ustar, calc_obklen + use ref_pres, only: top_lev => trop_cloud_top_lev + use zm_conv_intr, only: zmconv_microp + implicit none + + private + save + + ! ----------------- ! + ! Public interfaces ! + ! ----------------- ! + + public :: clubb_ini_cam, clubb_register_cam, clubb_tend_cam, & +#ifdef CLUBB_SGS + ! This utilizes CLUBB specific variables in its interface + stats_init_clubb, & +#endif + stats_end_timestep_clubb, & + clubb_readnl, & + clubb_init_cnst, & + clubb_implements_cnst + +#ifdef CLUBB_SGS + ! Both of these utilize CLUBB specific variables in their interface + private :: stats_zero, stats_avg +#endif + + logical, public :: do_cldcool + + ! ------------ ! + ! Private data ! + ! ------------ ! + + integer, parameter :: & + grid_type = 3, & ! The 2 option specifies stretched thermodynamic levels + hydromet_dim = 0 ! The hydromet array in SAM-CLUBB is currently 0 elements + + real(r8), parameter, dimension(0) :: & + sclr_tol = 1.e-8_r8 ! Total water in kg/kg + + character(len=6), parameter :: & + saturation_equation = "gfdl" ! Goff & Gratch (1946) approximation for SVP + + real(r8), parameter :: & + theta0 = 300._r8, & ! Reference temperature [K] + ts_nudge = 86400._r8, & ! Time scale for u/v nudging (not used) [s] + p0_clubb = 100000._r8 + + integer, parameter :: & + sclr_dim = 0 ! Higher-order scalars, set to zero + + real(r8), parameter :: & + wp3_const = 1._r8 ! Constant to add to wp3 when moments are advected + + real(r8), parameter :: & + wpthlp_const = 10.0_r8 ! Constant to add to wpthlp when moments are advected + + real(r8), parameter :: & + wprtp_const = 0.01_r8 ! Constant to add to wprtp when moments are advected + + real(r8), parameter :: & + rtpthlp_const = 0.01_r8 ! Constant to add to rtpthlp when moments are advected + + real(r8), parameter :: unset_r8 = huge(1.0_r8) + + real(r8) :: clubb_timestep = unset_r8 ! Default CLUBB timestep, unless overwriten by namelist + real(r8) :: clubb_rnevap_effic = unset_r8 + + real(r8) :: clubb_c11 = unset_r8 + real(r8) :: clubb_c11b = unset_r8 + real(r8) :: clubb_c14 = unset_r8 + real(r8) :: clubb_gamma_coef = unset_r8 + real(r8) :: clubb_c_K10 = unset_r8 + real(r8) :: clubb_c_K10h = unset_r8 + real(r8) :: clubb_beta = unset_r8 + real(r8) :: clubb_C2rt = unset_r8 + real(r8) :: clubb_C2thl = unset_r8 + real(r8) :: clubb_C2rtthl = unset_r8 + real(r8) :: clubb_C8 = unset_r8 + real(r8) :: clubb_C7 = unset_r8 + real(r8) :: clubb_C7b = unset_r8 + real(r8) :: clubb_Skw_denom_coef = unset_r8 + real(r8) :: clubb_lambda0_stability_coef = unset_r8 + real(r8) :: clubb_mult_coef = unset_r8 + +! Constant parameters + logical, parameter, private :: & + l_uv_nudge = .false., & ! Use u/v nudging (not used) + l_implemented = .true., & ! Implemented in a host model (always true) + l_host_applies_sfc_fluxes = .false. ! Whether the host model applies the surface fluxes + + logical, parameter, private :: & + apply_to_heat = .false. ! Apply WACCM energy fixer to heat or not (.true. = yes (duh)) + + logical :: lq(pcnst) + logical :: prog_modal_aero + logical :: do_rainturb + logical :: do_expldiff + logical :: clubb_do_adv + logical :: clubb_do_liqsupersat = .false. + logical :: clubb_do_energyfix = .true. + logical :: history_budget + + logical :: clubb_l_lscale_plume_centered + logical :: clubb_l_use_ice_latent + + integer :: history_budget_histfile_num + integer :: edsclr_dim ! Number of scalars to transport in CLUBB + integer :: offset + +! define physics buffer indicies here + integer :: & + wp2_idx, & ! vertical velocity variances + wp3_idx, & ! third moment of vertical velocity + wpthlp_idx, & ! turbulent flux of thetal + wprtp_idx, & ! turbulent flux of total water + rtpthlp_idx, & ! covariance of thetal and rt + rtp2_idx, & ! variance of total water + thlp2_idx, & ! variance of thetal + up2_idx, & ! variance of east-west wind + vp2_idx, & ! variance of north-south wind + upwp_idx, & ! east-west momentum flux + vpwp_idx, & ! north-south momentum flux + thlm_idx, & ! mean thetal + rtm_idx, & ! mean total water mixing ratio + um_idx, & ! mean of east-west wind + vm_idx, & ! mean of north-south wind + cld_idx, & ! Cloud fraction + concld_idx, & ! Convective cloud fraction + ast_idx, & ! Stratiform cloud fraction + alst_idx, & ! Liquid stratiform cloud fraction + aist_idx, & ! Ice stratiform cloud fraction + qlst_idx, & ! Physical in-cloud LWC + qist_idx, & ! Physical in-cloud IWC + dp_frac_idx, & ! deep convection cloud fraction + sh_frac_idx, & ! shallow convection cloud fraction + kvh_idx, & ! Eddy diffusivity of heat/moisture on interface levels + pblh_idx, & ! PBL pbuf + icwmrdp_idx, & ! In cloud mixing ratio for deep convection + tke_idx, & ! turbulent kinetic energy + tpert_idx, & ! temperature perturbation from PBL + fice_idx, & ! fice_idx index in physics buffer + cmeliq_idx, & ! cmeliq_idx index in physics buffer + relvar_idx, & ! relative cloud water variance + accre_enhan_idx, & ! optional accretion enhancement factor for MG + npccn_idx, & ! liquid ccn number concentration + naai_idx, & ! ice number concentration + prer_evap_idx, & ! rain evaporation rate + qrl_idx, & ! longwave cooling rate + radf_idx , & + qsatfac_idx ! subgrid cloud water saturation scaling factor + + integer, public :: & + ixthlp2 = 0, & + ixwpthlp = 0, & + ixwprtp = 0, & + ixwp2 = 0, & + ixwp3 = 0, & + ixrtpthlp = 0, & + ixrtp2 = 0, & + ixup2 = 0, & + ixvp2 = 0 + + integer :: cmfmc_sh_idx = 0 + + integer :: & + dlfzm_idx = -1, & ! ZM detrained convective cloud water mixing ratio. + difzm_idx = -1, & ! ZM detrained convective cloud ice mixing ratio. + dnlfzm_idx = -1, & ! ZM detrained convective cloud water num concen. + dnifzm_idx = -1 ! ZM detrained convective cloud ice num concen. + + ! Output arrays for CLUBB statistics + real(r8), allocatable, dimension(:,:,:) :: out_zt, out_zm, out_radzt, out_radzm, out_sfc + + character(len=16) :: eddy_scheme ! Default set in phys_control.F90 + character(len=16) :: deep_scheme ! Default set in phys_control.F90 + + integer, parameter :: ncnst=9 + character(len=8) :: cnst_names(ncnst) + logical :: do_cnst=.false. + + contains + + ! =============================================================================== ! + ! ! + ! =============================================================================== ! + + subroutine clubb_register_cam( ) +!------------------------------------------------------------------------------- +! Description: +! Register the constituents and fields in the physics buffer +! Author: P. Bogenschutz, C. Craig, A. Gettelman +! +!------------------------------------------------------------------------------- +#ifdef CLUBB_SGS + + !------------------------------------------------ ! + ! Register physics buffer fields and constituents ! + !------------------------------------------------ ! + + ! Add CLUBB fields to pbuf + use physics_buffer, only: pbuf_add_field, dtype_r8, dyn_time_lvls + + call phys_getopts( eddy_scheme_out = eddy_scheme, & + deep_scheme_out = deep_scheme, & + history_budget_out = history_budget, & + history_budget_histfile_num_out = history_budget_histfile_num ) + + if (clubb_do_adv) then + cnst_names =(/'THLP2 ','RTP2 ','RTPTHLP','WPTHLP ','WPRTP ','WP2 ','WP3 ','UP2 ','VP2 '/) + do_cnst=.true. + ! If CLUBB moments are advected, do not output them automatically which is typically done. Some moments + ! need a constant added to them before they are advected, thus this would corrupt the output. + ! Users should refer to the "XXXX_CLUBB" (THLP2_CLUBB for instance) output variables for these moments + call cnst_add(trim(cnst_names(1)),0._r8,0._r8,0._r8,ixthlp2,longname='second moment vertical velocity',cam_outfld=.false.) + call cnst_add(trim(cnst_names(2)),0._r8,0._r8,0._r8,ixrtp2,longname='second moment rtp',cam_outfld=.false.) + call cnst_add(trim(cnst_names(3)),0._r8,0._r8,-999999._r8,ixrtpthlp,longname='covariance rtp thlp',cam_outfld=.false.) + call cnst_add(trim(cnst_names(4)),0._r8,0._r8,-999999._r8,ixwpthlp,longname='CLUBB heat flux',cam_outfld=.false.) + call cnst_add(trim(cnst_names(5)),0._r8,0._r8,-999999._r8,ixwprtp,longname='CLUBB moisture flux',cam_outfld=.false.) + call cnst_add(trim(cnst_names(6)),0._r8,0._r8,0._r8,ixwp2,longname='CLUBB wp2',cam_outfld=.false.) + call cnst_add(trim(cnst_names(7)),0._r8,0._r8,-999999._r8,ixwp3,longname='CLUBB 3rd moment vert velocity',cam_outfld=.false.) + call cnst_add(trim(cnst_names(8)),0._r8,0._r8,0._r8,ixup2,longname='CLUBB 2nd moment u wind',cam_outfld=.false.) + call cnst_add(trim(cnst_names(9)),0._r8,0._r8,0._r8,ixvp2,longname='CLUBB 2nd moment v wind',cam_outfld=.false.) + end if + + ! put pbuf_add calls here (see macrop_driver.F90 for sample) use indicies defined at top + call pbuf_add_field('pblh', 'global', dtype_r8, (/pcols/), pblh_idx) + call pbuf_add_field('tke', 'global', dtype_r8, (/pcols, pverp/), tke_idx) + call pbuf_add_field('kvh', 'global', dtype_r8, (/pcols, pverp/), kvh_idx) + call pbuf_add_field('tpert', 'global', dtype_r8, (/pcols/), tpert_idx) + call pbuf_add_field('AST', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), ast_idx) + call pbuf_add_field('AIST', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), aist_idx) + call pbuf_add_field('ALST', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), alst_idx) + call pbuf_add_field('QIST', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), qist_idx) + call pbuf_add_field('QLST', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), qlst_idx) + call pbuf_add_field('CONCLD', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), concld_idx) + call pbuf_add_field('CLD', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cld_idx) + call pbuf_add_field('FICE', 'physpkg',dtype_r8, (/pcols,pver/), fice_idx) + call pbuf_add_field('RAD_CLUBB', 'global', dtype_r8, (/pcols,pver/), radf_idx) + call pbuf_add_field('CMELIQ', 'physpkg',dtype_r8, (/pcols,pver/), cmeliq_idx) + call pbuf_add_field('QSATFAC', 'physpkg',dtype_r8, (/pcols,pver/), qsatfac_idx) + + + call pbuf_add_field('WP2_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), wp2_idx) + call pbuf_add_field('WP3_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), wp3_idx) + call pbuf_add_field('WPTHLP_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), wpthlp_idx) + call pbuf_add_field('WPRTP_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), wprtp_idx) + call pbuf_add_field('RTPTHLP_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), rtpthlp_idx) + call pbuf_add_field('RTP2_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), rtp2_idx) + call pbuf_add_field('THLP2_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), thlp2_idx) + call pbuf_add_field('UP2_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), up2_idx) + call pbuf_add_field('VP2_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), vp2_idx) + + call pbuf_add_field('UPWP', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), upwp_idx) + call pbuf_add_field('VPWP', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), vpwp_idx) + call pbuf_add_field('THLM', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), thlm_idx) + call pbuf_add_field('RTM', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), rtm_idx) + call pbuf_add_field('UM', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), um_idx) + call pbuf_add_field('VM', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), vm_idx) + +#endif + + end subroutine clubb_register_cam + ! =============================================================================== ! + ! ! + ! =============================================================================== ! + +function clubb_implements_cnst(name) + + !----------------------------------------------------------------------------- ! + ! ! + ! Return true if specified constituent is implemented by this package ! + ! ! + !----------------------------------------------------------------------------- ! + + character(len=*), intent(in) :: name ! constituent name + logical :: clubb_implements_cnst ! return value + + !----------------------------------------------------------------------- + + clubb_implements_cnst = (do_cnst .and. any(name == cnst_names)) + +end function clubb_implements_cnst + + + ! =============================================================================== ! + ! ! + ! =============================================================================== ! + +subroutine clubb_init_cnst(name, latvals, lonvals, mask, q) +#ifdef CLUBB_SGS + use constants_clubb, only: w_tol_sqd, rt_tol, thl_tol +#endif + + !----------------------------------------------------------------------- ! + ! ! + ! Initialize the state if clubb_do_adv ! + ! ! + !----------------------------------------------------------------------- ! + + character(len=*), intent(in) :: name ! constituent name + real(r8), intent(in) :: latvals(:) ! lat in degrees (ncol) + real(r8), intent(in) :: lonvals(:) ! lon in degrees (ncol) + logical, intent(in) :: mask(:) ! Only initialize where .true. + real(r8), intent(out) :: q(:,:) ! kg tracer/kg dry air (gcol, plev + + !----------------------------------------------------------------------- + integer :: k, nlev + +#ifdef CLUBB_SGS + if (clubb_do_adv) then + nlev = size(q, 2) + do k = 1, nlev + if (trim(name) == trim(cnst_names(1))) then + where(mask) + q(:,k) = thl_tol**2 + end where + end if + if (trim(name) == trim(cnst_names(2))) then + where(mask) + q(:,k) = rt_tol**2 + end where + end if + if (trim(name) == trim(cnst_names(3))) then + where(mask) + q(:,k) = 0.0_r8 + end where + end if + if (trim(name) == trim(cnst_names(4))) then + where(mask) + q(:,k) = 0.0_r8 + end where + end if + if (trim(name) == trim(cnst_names(5))) then + where(mask) + q(:,k) = 0.0_r8 + end where + end if + if (trim(name) == trim(cnst_names(6))) then + where(mask) + q(:,k) = w_tol_sqd + end where + end if + if (trim(name) == trim(cnst_names(7))) then + where(mask) + q(:,k) = 0.0_r8 + end where + end if + if (trim(name) == trim(cnst_names(8))) then + where(mask) + q(:,k) = w_tol_sqd + end where + end if + if (trim(name) == trim(cnst_names(9))) then + where(mask) + q(:,k) = w_tol_sqd + end where + end if + end do + end if +#endif + +end subroutine clubb_init_cnst + + + ! =============================================================================== ! + ! ! + ! =============================================================================== ! + + subroutine clubb_readnl(nlfile) + +#ifdef CLUBB_SGS + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use cam_abortutils, only: endrun + use stats_variables, only: l_stats, l_output_rad_files + use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_logical, mpi_real8 + use clubb_api_module, only: l_diffuse_rtm_and_thlm, l_stability_correct_Kh_N2_zm +#endif + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + +#ifdef CLUBB_SGS + + character(len=*), parameter :: sub = 'clubb_readnl' + + logical :: clubb_history, clubb_rad_history, clubb_cloudtop_cooling, clubb_rainevap_turb, & + clubb_stabcorrect, clubb_expldiff ! Stats enabled (T/F) + + integer :: iunit, read_status, ierr + + namelist /clubb_his_nl/ clubb_history, clubb_rad_history + namelist /clubbpbl_diff_nl/ clubb_cloudtop_cooling, clubb_rainevap_turb, clubb_expldiff, & + clubb_do_adv, clubb_timestep, clubb_stabcorrect, & + clubb_rnevap_effic + namelist /clubb_params_nl/ clubb_c11, clubb_c11b, clubb_c14, clubb_mult_coef, clubb_gamma_coef, & + clubb_c_K10, clubb_c_K10h, clubb_beta, clubb_C2rt, clubb_C2thl, & + clubb_C2rtthl, clubb_C8, clubb_C7, clubb_C7b, clubb_Skw_denom_coef, & + clubb_lambda0_stability_coef, clubb_l_lscale_plume_centered, & + clubb_l_use_ice_latent, clubb_do_liqsupersat, clubb_do_energyfix + + !----- Begin Code ----- + + ! Determine if we want clubb_history to be output + clubb_history = .false. ! Initialize to false + l_stats = .false. ! Initialize to false + l_output_rad_files = .false. ! Initialize to false + do_cldcool = .false. ! Initialize to false + do_rainturb = .false. ! Initialize to false + do_expldiff = .false. ! Initialize to false + + clubb_l_lscale_plume_centered = .false. ! Initialize to false! + clubb_l_use_ice_latent = .false. ! Initialize to false! + + ! Read namelist to determine if CLUBB history should be called + if (masterproc) then + iunit = getunit() + open( iunit, file=trim(nlfile), status='old' ) + + call find_group_name(iunit, 'clubb_his_nl', status=read_status) + if (read_status == 0) then + read(unit=iunit, nml=clubb_his_nl, iostat=read_status) + if (read_status /= 0) then + call endrun('clubb_readnl: error reading namelist') + end if + end if + + call find_group_name(iunit, 'clubb_params_nl', status=read_status) + if (read_status == 0) then + read(unit=iunit, nml=clubb_params_nl, iostat=read_status) + if (read_status /= 0) then + call endrun('clubb_readnl: error reading namelist') + end if + else + call endrun('clubb_readnl: error reading namelist') + end if + + call find_group_name(iunit, 'clubbpbl_diff_nl', status=read_status) + if (read_status == 0) then + read(unit=iunit, nml=clubbpbl_diff_nl, iostat=read_status) + if (read_status /= 0) then + call endrun('clubb_readnl: error reading namelist') + end if + end if + + close(unit=iunit) + call freeunit(iunit) + end if + + ! Broadcast namelist variables + call mpi_bcast(clubb_history, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_history") + call mpi_bcast(clubb_rad_history, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_rad_history") + call mpi_bcast(clubb_cloudtop_cooling, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_cloudtop_cooling") + call mpi_bcast(clubb_rainevap_turb, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_rainevap_turb") + call mpi_bcast(clubb_expldiff, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_expldiff") + call mpi_bcast(clubb_do_adv, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_do_adv") + call mpi_bcast(clubb_timestep, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_timestep") + call mpi_bcast(clubb_stabcorrect, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_stabcorrect") + call mpi_bcast(clubb_rnevap_effic, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_rnevap_effic") + + call mpi_bcast(clubb_c11, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_c11") + call mpi_bcast(clubb_c11b, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_c11b") + call mpi_bcast(clubb_c14, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_c14") + call mpi_bcast(clubb_mult_coef, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_mult_coef") + call mpi_bcast(clubb_gamma_coef, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_gamma_coef") + call mpi_bcast(clubb_c_K10, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_c_K10") + call mpi_bcast(clubb_c_K10h, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_c_K10h") + call mpi_bcast(clubb_beta, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_beta") + call mpi_bcast(clubb_C2rt, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_C2rt") + call mpi_bcast(clubb_C2thl, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_C2thl") + call mpi_bcast(clubb_C2rtthl, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_C2rtthl") + call mpi_bcast(clubb_C8, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_C8") + call mpi_bcast(clubb_C7, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_C7") + call mpi_bcast(clubb_C7b, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_C7b") + call mpi_bcast(clubb_Skw_denom_coef, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_Skw_denom_coef") + call mpi_bcast(clubb_lambda0_stability_coef, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_lambda0_stability_coef") + call mpi_bcast(clubb_l_lscale_plume_centered,1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_lscale_plume_centered") + call mpi_bcast(clubb_l_use_ice_latent, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_use_ice_latent") + call mpi_bcast(clubb_do_liqsupersat, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_do_liqsupersat") + call mpi_bcast(clubb_do_energyfix, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_do_energyfix") + + ! Overwrite defaults if they are true + if (clubb_history) l_stats = .true. + if (clubb_rad_history) l_output_rad_files = .true. + if (clubb_cloudtop_cooling) do_cldcool = .true. + if (clubb_rainevap_turb) do_rainturb = .true. + if (clubb_expldiff) do_expldiff = .true. + + if (clubb_stabcorrect .and. clubb_expldiff) then + call endrun('clubb_readnl: clubb_stabcorrect and clubb_expldiff may not both be set to true at the same time') + end if + + if (clubb_stabcorrect) then + l_diffuse_rtm_and_thlm = .true. ! CLUBB flag set to true + l_stability_correct_Kh_N2_zm = .true. ! CLUBB flag set to true + endif + +#endif + end subroutine clubb_readnl + + ! =============================================================================== ! + ! ! + ! =============================================================================== ! + + subroutine clubb_ini_cam(pbuf2d) +!------------------------------------------------------------------------------- +! Description: +! Initialize UWM CLUBB. +! Author: Cheryl Craig March 2011 +! Modifications: Pete Bogenschutz 2011 March and onward +! Origin: Based heavily on UWM clubb_init.F90 +! References: +! None +!------------------------------------------------------------------------------- + + + +#ifdef CLUBB_SGS + + ! From CAM libraries + use cam_history, only: addfld, add_default, horiz_only + use ref_pres, only: pref_mid + use hb_diff, only: init_hb_diff + use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_mode_num_idx, rad_cnst_get_mam_mmr_idx + use cam_abortutils, only: endrun + + ! From the CLUBB libraries + use clubb_api_module, only: & + setup_clubb_core_api, & + time_precision, & + core_rknd, & + set_clubb_debug_level_api, & + nparams, & + read_parameters_api, & + l_stats, & + l_stats_samp, & + l_grads, & + stats_zt, & + stats_zm, & + stats_sfc, & + stats_rad_zt, & + stats_rad_zm, & + w_tol_sqd, & + rt_tol, & + thl_tol + + ! These are only needed if we're using a passive scalar + use clubb_api_module, only: & + iisclr_rt, & + iisclr_thl, & + iisclr_CO2, & + iiedsclr_rt, & + iiedsclr_thl, & + iiedsclr_CO2 + + ! These are needed to set parameters + use clubb_api_module, only: & + ilambda0_stability_coef, ic_K10, ic_K10h, iC2rtthl, iC7, iC7b, iC8, iC11, iC11b, & + iC14, igamma_coef, imult_coef, ilmin_coef, iSkw_denom_coef, ibeta, & + iC2rt, iC2thl, iC2rtthl, l_do_expldiff_rtm_thlm, l_Lscale_plume_centered, & + l_use_ice_latent + + use time_manager, only: is_first_step + + use constituents, only: cnst_get_ind + use phys_control, only: phys_getopts + +#endif + + use physics_buffer, only: pbuf_get_index, pbuf_set_field, physics_buffer_desc + implicit none + ! Input Variables + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + +#ifdef CLUBB_SGS + + real(kind=time_precision) :: dum1, dum2, dum3 + + real(r8), dimension(nparams) :: clubb_params ! These adjustable CLUBB parameters (C1, C2 ...) + + ! The similar name to clubb_history is unfortunate... + logical :: history_amwg, history_clubb + + integer :: err_code ! Code for when CLUBB fails + integer :: k, l ! Indices + integer :: ntop_eddy ! Top interface level to which eddy vertical diffusion is applied ( = 1 ) + integer :: nbot_eddy ! Bottom interface level to which eddy vertical diffusion is applied ( = pver ) + integer :: nmodes, nspec, m + integer :: ixq, ixcldice, ixcldliq, ixnumliq, ixnumice + integer :: lptr + + real(r8) :: zt_g(pverp+1-top_lev) ! Height dummy array + real(r8) :: zi_g(pverp+1-top_lev) ! Height dummy array + + ! CAM defines zi at the surface to be zero. + real(r8), parameter :: sfc_elevation = 0._r8 + + integer :: nlev + + !----- Begin Code ----- + + nlev = pver + 1 - top_lev + + if (core_rknd /= r8) then + call endrun('clubb_ini_cam: CLUBB library core_rknd must match CAM r8 and it does not') + end if + + ! ----------------------------------------------------------------- ! + ! Determine how many constituents CLUBB will transport. Note that + ! CLUBB does not transport aerosol consituents. Therefore, need to + ! determine how many aerosols constituents there are and subtract that + ! off of pcnst (the total consituents) + ! ----------------------------------------------------------------- ! + + call phys_getopts(prog_modal_aero_out=prog_modal_aero, & + history_amwg_out=history_amwg, & + history_clubb_out=history_clubb) + + ! Select variables to apply tendencies back to CAM + + ! Initialize all consituents to true to start + lq(1:pcnst) = .true. + edsclr_dim = pcnst + + call cnst_get_ind('Q',ixq) + call cnst_get_ind('NUMICE',ixnumice) + call cnst_get_ind('NUMLIQ',ixnumliq) + call cnst_get_ind('CLDLIQ',ixcldliq) + call cnst_get_ind('CLDICE',ixcldice) + + if (prog_modal_aero) then + ! Turn off modal aerosols and decrement edsclr_dim accordingly + call rad_cnst_get_info(0, nmodes=nmodes) + + do m = 1, nmodes + call rad_cnst_get_mode_num_idx(m, lptr) + lq(lptr)=.false. + edsclr_dim = edsclr_dim-1 + + call rad_cnst_get_info(0, m, nspec=nspec) + do l = 1, nspec + call rad_cnst_get_mam_mmr_idx(m, l, lptr) + lq(lptr)=.false. + edsclr_dim = edsclr_dim-1 + end do + end do + + ! In addition, if running with MAM, droplet number is transported + ! in dropmixnuc, therefore we do NOT want CLUBB to apply transport + ! tendencies to avoid double counted. Else, we apply tendencies. + lq(ixnumliq) = .false. + edsclr_dim = edsclr_dim-1 + endif + + ! ----------------------------------------------------------------- ! + ! Set the debug level. Level 2 has additional computational expense since + ! it checks the array variables in CLUBB for invalid values. + ! ----------------------------------------------------------------- ! + call set_clubb_debug_level_api( 0 ) + + ! ----------------------------------------------------------------- ! + ! use pbuf_get_fld_idx to get existing physics buffer fields from other + ! physics packages (e.g. tke) + ! ----------------------------------------------------------------- ! + + + ! Defaults + l_stats_samp = .false. + l_grads = .false. + + ! Overwrite defaults if needbe + if (l_stats) l_stats_samp = .true. + + ! Define physics buffers indexes + cld_idx = pbuf_get_index('CLD') ! Cloud fraction + concld_idx = pbuf_get_index('CONCLD') ! Convective cloud cover + ast_idx = pbuf_get_index('AST') ! Stratiform cloud fraction + alst_idx = pbuf_get_index('ALST') ! Liquid stratiform cloud fraction + aist_idx = pbuf_get_index('AIST') ! Ice stratiform cloud fraction + qlst_idx = pbuf_get_index('QLST') ! Physical in-stratus LWC + qist_idx = pbuf_get_index('QIST') ! Physical in-stratus IWC + dp_frac_idx = pbuf_get_index('DP_FRAC') ! Deep convection cloud fraction + icwmrdp_idx = pbuf_get_index('ICWMRDP') ! In-cloud deep convective mixing ratio + sh_frac_idx = pbuf_get_index('SH_FRAC') ! Shallow convection cloud fraction + relvar_idx = pbuf_get_index('RELVAR') ! Relative cloud water variance + accre_enhan_idx = pbuf_get_index('ACCRE_ENHAN') ! accretion enhancement for MG + prer_evap_idx = pbuf_get_index('PRER_EVAP') + qrl_idx = pbuf_get_index('QRL') + cmfmc_sh_idx = pbuf_get_index('CMFMC_SH') + + + iisclr_rt = -1 + iisclr_thl = -1 + iisclr_CO2 = -1 + + iiedsclr_rt = -1 + iiedsclr_thl = -1 + iiedsclr_CO2 = -1 + + if (zmconv_microp) then + dlfzm_idx = pbuf_get_index('DLFZM') + difzm_idx = pbuf_get_index('DIFZM') + dnlfzm_idx = pbuf_get_index('DNLFZM') + dnifzm_idx = pbuf_get_index('DNIFZM') + end if + + ! ----------------------------------------------------------------- ! + ! Define number of tracers for CLUBB to diffuse + ! ----------------------------------------------------------------- ! + + if (do_expldiff) then + offset = 2 ! diffuse temperature and moisture explicitly + edsclr_dim = edsclr_dim + offset + endif + + ! ----------------------------------------------------------------- ! + ! Setup CLUBB core + ! ----------------------------------------------------------------- ! + + ! Read in parameters for CLUBB. Just read in default values + call read_parameters_api( -99, "", clubb_params ) + + ! Fill in dummy arrays for height. Note that these are overwrote + ! at every CLUBB step to physical values. + do k=1,nlev+1 + zt_g(k) = ((k-1)*1000._r8)-500._r8 ! this is dummy garbage + zi_g(k) = (k-1)*1000._r8 ! this is dummy garbage + enddo + + ! Set CLUBB parameters + clubb_params(ilambda0_stability_coef) = clubb_lambda0_stability_coef + clubb_params(ic_K10) = clubb_c_K10 + clubb_params(ic_K10h) = clubb_c_K10h + clubb_params(iC2rtthl) = clubb_C2rtthl + clubb_params(iC2rt) = clubb_C2rt + clubb_params(iC2thl) = clubb_C2thl + clubb_params(ibeta) = clubb_beta + clubb_params(iC7) = clubb_C7 + clubb_params(iC7b) = clubb_C7b + clubb_params(iC8) = clubb_C8 + clubb_params(iC11) = clubb_c11 + clubb_params(iC11b) = clubb_c11b + clubb_params(iC14) = clubb_c14 + clubb_params(igamma_coef) = clubb_gamma_coef + clubb_params(imult_coef) = clubb_mult_coef + clubb_params(iSkw_denom_coef) = clubb_Skw_denom_coef + clubb_params(ilmin_coef) = 0.1_r8 + +!$OMP PARALLEL + l_do_expldiff_rtm_thlm = do_expldiff + l_Lscale_plume_centered = clubb_l_lscale_plume_centered + l_use_ice_latent = clubb_l_use_ice_latent + + ! Set up CLUBB core. Note that some of these inputs are overwritten + ! when clubb_tend_cam is called. The reason is that heights can change + ! at each time step, which is why dummy arrays are read in here for heights + ! as they are immediately overwrote. + call setup_clubb_core_api & + ( nlev+1, theta0, ts_nudge, & ! In + hydromet_dim, sclr_dim, & ! In + sclr_tol, edsclr_dim, clubb_params, & ! In + l_host_applies_sfc_fluxes, & ! In + l_uv_nudge, saturation_equation, & ! In + l_implemented, grid_type, zi_g(2), zi_g(1), zi_g(nlev+1),& ! In + zi_g(1:nlev+1), zt_g(1:nlev+1), sfc_elevation, & ! In + err_code ) +!$OMP END PARALLEL + + ! ----------------------------------------------------------------- ! + ! Set-up HB diffusion. Only initialized to diagnose PBL depth ! + ! ----------------------------------------------------------------- ! + + ! Initialize eddy diffusivity module + + ntop_eddy = 1 ! if >1, must be <= nbot_molec + nbot_eddy = pver ! currently always pver + + call init_hb_diff( gravit, cpair, ntop_eddy, nbot_eddy, pref_mid, karman, eddy_scheme ) + + ! ----------------------------------------------------------------- ! + ! Add output fields for the history files + ! ----------------------------------------------------------------- ! + + ! These are default CLUBB output. Not the higher order history budgets + call addfld ('RHO_CLUBB', (/ 'ilev' /), 'A', 'kg/m3', 'Air Density') + call addfld ('UP2_CLUBB', (/ 'ilev' /), 'A', 'm2/s2', 'Zonal Velocity Variance') + call addfld ('VP2_CLUBB', (/ 'ilev' /), 'A', 'm2/s2', 'Meridional Velocity Variance') + call addfld ('WP2_CLUBB', (/ 'ilev' /), 'A', 'm2/s2', 'Vertical Velocity Variance') + call addfld ('UPWP_CLUBB', (/ 'ilev' /), 'A', 'm2/s2', 'Zonal Momentum Flux') + call addfld ('VPWP_CLUBB', (/ 'ilev' /), 'A', 'm2/s2', 'Meridional Momentum Flux') + call addfld ('WP3_CLUBB', (/ 'ilev' /), 'A', 'm3/s3', 'Third Moment Vertical Velocity') + call addfld ('WPTHLP_CLUBB', (/ 'ilev' /), 'A', 'W/m2', 'Heat Flux') + call addfld ('WPRTP_CLUBB', (/ 'ilev' /), 'A', 'W/m2', 'Moisture Flux') + call addfld ('RTP2_CLUBB', (/ 'ilev' /), 'A', 'g^2/kg^2', 'Moisture Variance') + call addfld ('THLP2_CLUBB', (/ 'ilev' /), 'A', 'K^2', 'Temperature Variance') + call addfld ('RTPTHLP_CLUBB', (/ 'ilev' /), 'A', 'K g/kg', 'Temp. Moist. Covariance') + call addfld ('RCM_CLUBB', (/ 'ilev' /), 'A', 'g/kg', 'Cloud Water Mixing Ratio') + call addfld ('WPRCP_CLUBB', (/ 'ilev' /), 'A', 'W/m2', 'Liquid Water Flux') + call addfld ('CLOUDFRAC_CLUBB', (/ 'lev' /), 'A', 'fraction', 'Cloud Fraction') + call addfld ('RCMINLAYER_CLUBB', (/ 'ilev' /), 'A', 'g/kg', 'Cloud Water in Layer') + call addfld ('CLOUDCOVER_CLUBB', (/ 'ilev' /), 'A', 'fraction', 'Cloud Cover') + call addfld ('WPTHVP_CLUBB', (/ 'lev' /), 'A', 'W/m2', 'Buoyancy Flux') + call addfld ('RVMTEND_CLUBB', (/ 'lev' /), 'A', 'g/kg /s', 'Water vapor tendency') + call addfld ('STEND_CLUBB', (/ 'lev' /), 'A', 'k/s', 'Temperature tendency') + call addfld ('RCMTEND_CLUBB', (/ 'lev' /), 'A', 'g/kg /s', 'Cloud Liquid Water Tendency') + call addfld ('RIMTEND_CLUBB', (/ 'lev' /), 'A', 'g/kg /s', 'Cloud Ice Tendency') + call addfld ('UTEND_CLUBB', (/ 'lev' /), 'A', 'm/s /s', 'U-wind Tendency') + call addfld ('VTEND_CLUBB', (/ 'lev' /), 'A', 'm/s /s', 'V-wind Tendency') + call addfld ('ZT_CLUBB', (/ 'ilev' /), 'A', 'm', 'Thermodynamic Heights') + call addfld ('ZM_CLUBB', (/ 'ilev' /), 'A', 'm', 'Momentum Heights') + call addfld ('UM_CLUBB', (/ 'ilev' /), 'A', 'm/s', 'Zonal Wind') + call addfld ('VM_CLUBB', (/ 'ilev' /), 'A', 'm/s', 'Meridional Wind') + call addfld ('THETAL', (/ 'lev' /), 'A', 'K', 'Liquid Water Potential Temperature') + call addfld ('PBLH', horiz_only, 'A', 'm', 'PBL height') + call addfld( 'PBLHMX', horiz_only, 'X', 'm', 'Maximum PBL height over output period') + call addfld( 'PBLHMN', horiz_only, 'M', 'm', 'Minimum PBL height over output period') + call addfld ('QT', (/ 'lev' /), 'A', 'kg/kg', 'Total water mixing ratio') + call addfld ('SL', (/ 'lev' /), 'A', 'J/kg', 'Liquid water static energy') + call addfld ('CLDST', (/ 'lev' /), 'A', 'fraction', 'Stratus cloud fraction') + call addfld ('ZMDLF', (/ 'lev' /), 'A', 'kg/kg/s', 'Detrained liquid water from ZM convection') + call addfld ('TTENDICE', (/ 'lev' /), 'A', 'K/s', 'T tendency from Ice Saturation Adjustment') + call addfld ('QVTENDICE', (/ 'lev' /), 'A', 'kg/kg/s', 'Q tendency from Ice Saturation Adjustment') + call addfld ('QCTENDICE', (/ 'lev' /), 'A', 'kg/kg/s', 'CLDICE tendency from Ice Saturation Adjustment') + call addfld ('NCTENDICE', (/ 'lev' /), 'A', 'kg/kg/s', 'NUMICE tendency from Ice Saturation Adjustment') + call addfld ('FQTENDICE', (/ 'lev' /), 'A', 'fraction', 'Frequency of Ice Saturation Adjustment') + + call addfld ('DPDLFLIQ', (/ 'lev' /), 'A', 'kg/kg/s', 'Detrained liquid water from deep convection') + call addfld ('DPDLFICE', (/ 'lev' /), 'A', 'kg/kg/s', 'Detrained ice from deep convection') + call addfld ('DPDLFT', (/ 'lev' /), 'A', 'K/s', 'T-tendency due to deep convective detrainment') + call addfld ('RELVAR', (/ 'lev' /), 'A', '-', 'Relative cloud water variance') + call addfld ('CLUBB_GRID_SIZE', horiz_only, 'A', 'm', 'Horizontal grid box size seen by CLUBB') + + + call addfld ('CONCLD', (/ 'lev' /), 'A', 'fraction', 'Convective cloud cover') + call addfld ('CMELIQ', (/ 'lev' /), 'A', 'kg/kg/s', 'Rate of cond-evap of liq within the cloud') + + call addfld ('QSATFAC', (/ 'lev' /), 'A', '-', 'Subgrid cloud water saturation scaling factor') + call addfld ('KVH_CLUBB', (/ 'ilev' /), 'A', 'm2/s', 'CLUBB vertical diffusivity of heat/moisture on interface levels') + + ! Initialize statistics, below are dummy variables + dum1 = 300._r8 + dum2 = 1200._r8 + dum3 = 300._r8 + + if (l_stats) then + + call stats_init_clubb( .true., dum1, dum2, & + nlev+1, nlev+1, nlev+1, dum3 ) + + allocate(out_zt(pcols,pverp,stats_zt%num_output_fields)) + allocate(out_zm(pcols,pverp,stats_zm%num_output_fields)) + allocate(out_sfc(pcols,1,stats_sfc%num_output_fields)) + + allocate(out_radzt(pcols,pverp,stats_rad_zt%num_output_fields)) + allocate(out_radzm(pcols,pverp,stats_rad_zm%num_output_fields)) + + endif + + ! ----------------------------------------------------------------- ! + ! Make all of this output default, this is not CLUBB history + ! ----------------------------------------------------------------- ! + if (clubb_do_adv .or. history_clubb) then + call add_default('WP2_CLUBB', 1, ' ') + call add_default('WP3_CLUBB', 1, ' ') + call add_default('WPTHLP_CLUBB', 1, ' ') + call add_default('WPRTP_CLUBB', 1, ' ') + call add_default('RTP2_CLUBB', 1, ' ') + call add_default('THLP2_CLUBB', 1, ' ') + call add_default('RTPTHLP_CLUBB', 1, ' ') + call add_default('UP2_CLUBB', 1, ' ') + call add_default('VP2_CLUBB', 1, ' ') + end if + + if (history_clubb) then + + call add_default('RELVAR', 1, ' ') + call add_default('RHO_CLUBB', 1, ' ') + call add_default('UPWP_CLUBB', 1, ' ') + call add_default('VPWP_CLUBB', 1, ' ') + call add_default('RCM_CLUBB', 1, ' ') + call add_default('WPRCP_CLUBB', 1, ' ') + call add_default('CLOUDFRAC_CLUBB', 1, ' ') + call add_default('RCMINLAYER_CLUBB', 1, ' ') + call add_default('CLOUDCOVER_CLUBB', 1, ' ') + call add_default('WPTHVP_CLUBB', 1, ' ') + call add_default('RVMTEND_CLUBB', 1, ' ') + call add_default('STEND_CLUBB', 1, ' ') + call add_default('RCMTEND_CLUBB', 1, ' ') + call add_default('RIMTEND_CLUBB', 1, ' ') + call add_default('UTEND_CLUBB', 1, ' ') + call add_default('VTEND_CLUBB', 1, ' ') + call add_default('ZT_CLUBB', 1, ' ') + call add_default('ZM_CLUBB', 1, ' ') + call add_default('UM_CLUBB', 1, ' ') + call add_default('VM_CLUBB', 1, ' ') + call add_default('SL', 1, ' ') + call add_default('QT', 1, ' ') + call add_default('CONCLD', 1, ' ') + + end if + + if (history_amwg) then + call add_default('PBLH', 1, ' ') + end if + + if (history_budget) then + call add_default('DPDLFLIQ', history_budget_histfile_num, ' ') + call add_default('DPDLFICE', history_budget_histfile_num, ' ') + call add_default('DPDLFT', history_budget_histfile_num, ' ') + call add_default('STEND_CLUBB', history_budget_histfile_num, ' ') + call add_default('RCMTEND_CLUBB', history_budget_histfile_num, ' ') + call add_default('RIMTEND_CLUBB', history_budget_histfile_num, ' ') + call add_default('RVMTEND_CLUBB', history_budget_histfile_num, ' ') + call add_default('UTEND_CLUBB', history_budget_histfile_num, ' ') + call add_default('VTEND_CLUBB', history_budget_histfile_num, ' ') + endif + + + ! --------------- ! + ! First step? ! + ! Initialization ! + ! --------------- ! + + ! Is this the first time step? If so then initialize CLUBB variables as follows + if (is_first_step()) then + + call pbuf_set_field(pbuf2d, wp2_idx, w_tol_sqd) + call pbuf_set_field(pbuf2d, wp3_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, wpthlp_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, wprtp_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, rtpthlp_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, rtp2_idx, rt_tol**2) + call pbuf_set_field(pbuf2d, thlp2_idx, thl_tol**2) + call pbuf_set_field(pbuf2d, up2_idx, w_tol_sqd) + call pbuf_set_field(pbuf2d, vp2_idx, w_tol_sqd) + + call pbuf_set_field(pbuf2d, upwp_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, vpwp_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, tke_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, kvh_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, radf_idx, 0.0_r8) + + endif + + ! The following is physpkg, so it needs to be initialized every time + call pbuf_set_field(pbuf2d, fice_idx, 0.0_r8) + + ! --------------- ! + ! End ! + ! Initialization ! + ! --------------- ! + +#endif + end subroutine clubb_ini_cam + + + ! =============================================================================== ! + ! ! + ! =============================================================================== ! + + subroutine clubb_tend_cam( & + state, ptend_all, pbuf, hdtime, & + cmfmc, cam_in, & + macmic_it, cld_macmic_num_steps,dlf, det_s, det_ice) + +!------------------------------------------------------------------------------- +! Description: Provide tendencies of shallow convection, turbulence, and +! macrophysics from CLUBB to CAM +! +! Author: Cheryl Craig, March 2011 +! Modifications: Pete Bogenschutz, March 2011 and onward +! Origin: Based heavily on UWM clubb_init.F90 +! References: +! None +!------------------------------------------------------------------------------- + + use physics_types, only: physics_state, physics_ptend, & + physics_state_copy, physics_ptend_init, & + physics_ptend_sum, physics_update + + use physics_buffer, only: pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field, & + physics_buffer_desc + + use constituents, only: cnst_get_ind + use camsrfexch, only: cam_in_t + use time_manager, only: is_first_step + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + use tropopause, only: tropopause_findChemTrop + +#ifdef CLUBB_SGS + use hb_diff, only: pblintd + use scamMOD, only: single_column,scm_clubb_iop_name + use clubb_api_module, only: & + nparams, & + read_parameters_api, & + setup_parameters_api, & + setup_grid_heights_api, & + w_tol_sqd, & + rt_tol, & + thl_tol, & + l_stats, & + stats_tsamp, & + stats_tout, & + stats_zt, & + stats_sfc, & + stats_zm, & + stats_rad_zt, & + stats_rad_zm, & + l_output_rad_files, & + pdf_parameter, & + stats_begin_timestep_api, & + advance_clubb_core_api, & + calculate_thlp2_rad_api, & + update_xp2_mc_api, & + zt2zm_api, zm2zt_api + + ! These are not exposed by the api module, but we want them anyway! + use cldfrc2m, only: aist_vector, rhmini_const, rhmaxi_const, rhminis_const, rhmaxis_const + use cam_history, only: outfld + + use macrop_driver, only: liquid_macro_tend +#endif + + implicit none + + ! --------------- ! + ! Input Auguments ! + ! --------------- ! + + type(physics_state), intent(in) :: state ! Physics state variables [vary] + type(cam_in_t), intent(in) :: cam_in + real(r8), intent(in) :: hdtime ! Host model timestep [s] + real(r8), intent(in) :: dlf(pcols,pver) ! Detraining cld H20 from deep convection [kg/ks/s] + real(r8), intent(in) :: cmfmc(pcols,pverp) ! convective mass flux--m sub c [kg/m2/s] + integer, intent(in) :: cld_macmic_num_steps ! number of mac-mic iterations + integer, intent(in) :: macmic_it ! number of mac-mic iterations + + ! ---------------------- ! + ! Input-Output Auguments ! + ! ---------------------- ! + + type(physics_buffer_desc), pointer :: pbuf(:) + + ! ---------------------- ! + ! Output Auguments ! + ! ---------------------- ! + + type(physics_ptend), intent(out) :: ptend_all ! package tendencies + + ! These two variables are needed for energy check + real(r8), intent(out) :: det_s(pcols) ! Integral of detrained static energy from ice + real(r8), intent(out) :: det_ice(pcols) ! Integral of detrained ice for energy check + + + ! --------------- ! + ! Local Variables ! + ! --------------- ! + +#ifdef CLUBB_SGS + + type(physics_state) :: state1 ! Local copy of state variable + type(physics_ptend) :: ptend_loc ! Local tendency from processes, added up to return as ptend_all + + integer :: i, k, t, ixind, nadv + integer :: ixcldice, ixcldliq, ixnumliq, ixnumice, ixq + integer :: itim_old + integer :: ncol, lchnk ! # of columns, and chunk identifier + integer :: err_code ! Diagnostic, for if some calculation goes amiss. + integer :: icnt, clubbtop + logical :: lq2(pcnst) + + + real(r8) :: frac_limit, ic_limit + + real(r8) :: dtime ! CLUBB time step [s] + real(r8) :: edsclr_in(pverp+1-top_lev,edsclr_dim) ! Scalars to be diffused through CLUBB [units vary] + real(r8) :: wp2_in(pverp+1-top_lev) ! vertical velocity variance (CLUBB) [m^2/s^2] + real(r8) :: wp3_in(pverp+1-top_lev) ! third moment vertical velocity [m^3/s^3] + real(r8) :: wpthlp_in(pverp+1-top_lev) ! turbulent flux of thetal [K m/s] + real(r8) :: wprtp_in(pverp+1-top_lev) ! turbulent flux of total water [kg/kg m/s] + real(r8) :: rtpthlp_in(pverp+1-top_lev) ! covariance of thetal and qt [kg/kg K] + real(r8) :: rtp2_in(pverp+1-top_lev) ! total water variance [kg^2/k^2] + real(r8) :: rtp3_in(pverp+1-top_lev) ! r_t'^3 (thermodynamic levels) (unused) [(kg/kg)^3] + real(r8) :: thlp2_in(pverp+1-top_lev) ! thetal variance [K^2] + real(r8) :: thlp3_in(pverp+1-top_lev) ! th_l'^3 (thermodynamic levels) (unused) [K^3] + real(r8) :: up2_in(pverp+1-top_lev) ! meridional wind variance [m^2/s^2] + real(r8) :: vp2_in(pverp+1-top_lev) ! zonal wind variance [m^2/s^2] + real(r8) :: upwp_in(pverp+1-top_lev) ! meridional wind flux [m^2/s^2] + real(r8) :: vpwp_in(pverp+1-top_lev) ! zonal wind flux [m^2/s^2] + real(r8) :: thlm_in(pverp+1-top_lev) ! liquid water potential temperature (thetal) [K] + real(r8) :: rtm_in(pverp+1-top_lev) ! total water mixing ratio [kg/kg] + real(r8) :: rvm_in(pverp+1-top_lev) ! water vapor mixing ratio [kg/kg] + real(r8) :: um_in(pverp+1-top_lev) ! meridional wind [m/s] + real(r8) :: vm_in(pverp+1-top_lev) ! zonal wind [m/s] + real(r8) :: rho_in(pverp+1-top_lev) ! mid-point density [kg/m^3] + real(r8) :: pre_in(pverp+1-top_lev) ! input for precip evaporation + real(r8) :: rtp2_mc_out(pverp+1-top_lev) ! total water tendency from rain evap + real(r8) :: thlp2_mc_out(pverp+1-top_lev) ! thetal tendency from rain evap + real(r8) :: wprtp_mc_out(pverp+1-top_lev) + real(r8) :: wpthlp_mc_out(pverp+1-top_lev) + real(r8) :: rtpthlp_mc_out(pverp+1-top_lev) + real(r8) :: rcm_out(pverp+1-top_lev) ! CLUBB output of liquid water mixing ratio [kg/kg] + real(r8) :: rcm_out_zm(pverp+1-top_lev) + real(r8) :: wprcp_out(pverp+1-top_lev) ! CLUBB output of flux of liquid water [kg/kg m/s] + real(r8) :: cloud_frac_out(pverp+1-top_lev) ! CLUBB output of cloud fraction [fraction] + real(r8) :: rcm_in_layer_out(pverp+1-top_lev)! CLUBB output of in-cloud liq. wat. mix. ratio [kg/kg] + real(r8) :: cloud_cover_out(pverp+1-top_lev) ! CLUBB output of in-cloud cloud fraction [fraction] + real(r8) :: thlprcp_out(pverp+1-top_lev) + real(r8) :: rho_ds_zm(pverp+1-top_lev) ! Dry, static density on momentum levels [kg/m^3] + real(r8) :: rho_ds_zt(pverp+1-top_lev) ! Dry, static density on thermodynamic levels [kg/m^3] + real(r8) :: invrs_rho_ds_zm(pverp+1-top_lev) ! Inv. dry, static density on momentum levels [m^3/kg] + real(r8) :: invrs_rho_ds_zt(pverp+1-top_lev) ! Inv. dry, static density on thermo. levels [m^3/kg] + real(r8) :: thv_ds_zm(pverp+1-top_lev) ! Dry, base-state theta_v on momentum levels [K] + real(r8) :: thv_ds_zt(pverp+1-top_lev) ! Dry, base-state theta_v on thermo. levels [K] + real(r8) :: rfrzm(pverp+1-top_lev) + real(r8) :: radf(pverp+1-top_lev) + real(r8) :: wprtp_forcing(pverp+1-top_lev) + real(r8) :: wpthlp_forcing(pverp+1-top_lev) + real(r8) :: rtp2_forcing(pverp+1-top_lev) + real(r8) :: thlp2_forcing(pverp+1-top_lev) + real(r8) :: rtpthlp_forcing(pverp+1-top_lev) + real(r8) :: ice_supersat_frac(pverp+1-top_lev) + real(r8) :: zt_g(pverp+1-top_lev) ! Thermodynamic grid of CLUBB [m] + real(r8) :: zi_g(pverp+1-top_lev) ! Momentum grid of CLUBB [m] + real(r8) :: zt_out(pcols,pverp) ! output for the thermo CLUBB grid [m] + real(r8) :: zi_out(pcols,pverp) ! output for momentum CLUBB grid [m] + real(r8) :: fcor ! Coriolis forcing [s^-1] + real(r8) :: sfc_elevation ! Elevation of ground [m AMSL] + real(r8) :: ubar ! surface wind [m/s] + real(r8) :: ustar ! surface stress [m/s] + real(r8) :: thlm_forcing(pverp+1-top_lev) ! theta_l forcing (thermodynamic levels) [K/s] + real(r8) :: rtm_forcing(pverp+1-top_lev) ! r_t forcing (thermodynamic levels) [(kg/kg)/s] + real(r8) :: um_forcing(pverp+1-top_lev) ! u wind forcing (thermodynamic levels) [m/s/s] + real(r8) :: vm_forcing(pverp+1-top_lev) ! v wind forcing (thermodynamic levels) [m/s/s] + real(r8) :: wm_zm(pverp+1-top_lev) ! w mean wind component on momentum levels [m/s] + real(r8) :: wm_zt(pverp+1-top_lev) ! w mean wind component on thermo. levels [m/s] + real(r8) :: p_in_Pa(pverp+1-top_lev) ! Air pressure (thermodynamic levels) [Pa] + real(r8) :: rho_zt(pverp+1-top_lev) ! Air density on thermo levels [kt/m^3] + real(r8) :: rho_zm(pverp+1-top_lev) ! Air density on momentum levels [kg/m^3] + real(r8) :: exner(pverp+1-top_lev) ! Exner function (thermodynamic levels) [-] + real(r8) :: wpthlp_sfc ! w' theta_l' at surface [(m K)/s] + real(r8) :: wprtp_sfc ! w' r_t' at surface [(kg m)/( kg s)] + real(r8) :: upwp_sfc ! u'w' at surface [m^2/s^2] + real(r8) :: vpwp_sfc ! v'w' at surface [m^2/s^2] + real(r8) :: sclrm_forcing(pverp+1-top_lev,sclr_dim) ! Passive scalar forcing [{units vary}/s] + real(r8) :: wpsclrp_sfc(sclr_dim) ! Scalar flux at surface [{units vary} m/s] + real(r8) :: edsclrm_forcing(pverp+1-top_lev,edsclr_dim)! Eddy passive scalar forcing [{units vary}/s] + real(r8) :: wpedsclrp_sfc(edsclr_dim) ! Eddy-scalar flux at surface [{units vary} m/s] + real(r8) :: sclrm(pverp+1-top_lev,sclr_dim) ! Passive scalar mean (thermo. levels) [units vary] + real(r8) :: wpsclrp(pverp+1-top_lev,sclr_dim)! w'sclr' (momentum levels) [{units vary} m/s] + real(r8) :: sclrp2(pverp+1-top_lev,sclr_dim) ! sclr'^2 (momentum levels) [{units vary}^2] + real(r8) :: sclrprtp(pverp+1-top_lev,sclr_dim) ! sclr'rt' (momentum levels) [{units vary} (kg/kg)] + real(r8) :: sclrpthlp(pverp+1-top_lev,sclr_dim) ! sclr'thlp' (momentum levels) [{units vary} (K)] + real(r8) :: hydromet(pverp+1-top_lev,hydromet_dim) + real(r8) :: wphydrometp(pverp+1-top_lev,hydromet_dim) + real(r8) :: wp2hmp(pverp+1-top_lev,hydromet_dim) + real(r8) :: rtphmp_zt(pverp+1-top_lev,hydromet_dim) + real(r8) :: thlphmp_zt (pverp+1-top_lev,hydromet_dim) + real(r8) :: bflx22 ! Variable for buoyancy flux for pbl [K m/s] + real(r8) :: khzm_out(pverp+1-top_lev) ! Eddy diffusivity of heat/moisture on momentum (i.e. interface) levels [m^2/s] + real(r8) :: khzt_out(pverp+1-top_lev) ! eddy diffusivity on thermo grids [m^2/s] + real(r8) :: qclvar_out(pverp+1-top_lev) ! cloud water variance [kg^2/kg^2] + real(r8) :: qclvar(pcols,pverp) ! cloud water variance [kg^2/kg^2] + real(r8) :: zo ! roughness height [m] + real(r8) :: dz_g(pver) ! thickness of layer [m] + real(r8) :: relvarmax + real(r8) :: se_upper_a, se_upper_b, se_upper_diss + real(r8) :: tw_upper_a, tw_upper_b, tw_upper_diss + real(r8) :: grid_dx(pcols), grid_dy(pcols) ! CAM grid [m] + real(r8) :: host_dx, host_dy ! CAM grid [m] + + ! Variables below are needed to compute energy integrals for conservation + real(r8) :: ke_a(pcols), ke_b(pcols), te_a(pcols), te_b(pcols) + real(r8) :: wv_a(pcols), wv_b(pcols), wl_b(pcols), wl_a(pcols) + real(r8) :: se_dis, se_a(pcols), se_b(pcols), clubb_s(pver) + + real(r8) :: exner_clubb(pcols,pverp) ! Exner function consistent with CLUBB [-] + real(r8) :: wpthlp_output(pcols,pverp) ! Heat flux output variable [W/m2] + real(r8) :: wprtp_output(pcols,pverp) ! Total water flux output variable [W/m2] + real(r8) :: wp3_output(pcols,pverp) ! wp3 output [m^3/s^3] + real(r8) :: rtpthlp_output(pcols,pverp) ! rtpthlp ouptut [K kg/kg] + real(r8) :: qt_output(pcols,pver) ! Total water mixing ratio for output [kg/kg] + real(r8) :: thetal_output(pcols,pver) ! Liquid water potential temperature output [K] + real(r8) :: sl_output(pcols,pver) ! Liquid water static energy [J/kg] + real(r8) :: ustar2(pcols) ! Surface stress for PBL height [m2/s2] + real(r8) :: rho(pcols,pverp) ! Midpoint density in CAM [kg/m^3] + real(r8) :: thv(pcols,pver) ! virtual potential temperature [K] + real(r8) :: edsclr_out(pverp,edsclr_dim) ! Scalars to be diffused through CLUBB [units vary] + real(r8) :: rcm(pcols,pverp) ! CLUBB cloud water mixing ratio [kg/kg] + real(r8) :: cloud_frac(pcols,pverp) ! CLUBB cloud fraction [fraction] + real(r8) :: rcm_in_layer(pcols,pverp) ! CLUBB in-cloud liquid water mixing ratio [kg/kg] + real(r8) :: wprcp(pcols,pverp) ! CLUBB liquid water flux [m/s kg/kg] + real(r8) :: wpthvp(pcols,pverp) ! CLUBB buoyancy flux [W/m^2] + real(r8) :: rvm(pcols,pverp) + real(r8) :: dlf2(pcols,pver) ! Detraining cld H20 from shallow convection [kg/kg/day] + real(r8) :: eps ! Rv/Rd [-] + real(r8) :: dum1 ! dummy variable [units vary] + real(r8) :: obklen(pcols) ! Obukov length [m] + real(r8) :: kbfs(pcols) ! Kinematic Surface heat flux [K m/s] + real(r8) :: th(pcols,pver) ! potential temperature [K] + real(r8) :: dummy2(pcols) ! dummy variable [units vary] + real(r8) :: dummy3(pcols) ! dummy variable [units vary] + real(r8) :: kinheat(pcols) ! Kinematic Surface heat flux [K m/s] + real(r8) :: rrho(pcols) ! Inverse of air density [1/kg/m^3] + real(r8) :: kinwat(pcols) ! Kinematic water vapor flux [m/s] + real(r8) :: latsub + real(r8) :: qrl_clubb(pverp+1-top_lev) + real(r8) :: qrl_zm(pverp+1-top_lev) + real(r8) :: thlp2_rad_out(pverp+1-top_lev) + real(r8) :: apply_const, rtm_test + + integer :: time_elapsed ! time keep track of stats [s] + real(r8), dimension(nparams) :: clubb_params ! These adjustable CLUBB parameters (C1, C2 ...) + type(pdf_parameter), dimension(pverp) :: pdf_params ! PDF parameters [units vary] + character(len=200) :: temp1, sub ! Strings needed for CLUBB output + + + ! --------------- ! + ! Pointers ! + ! --------------- ! + + real(r8), pointer, dimension(:,:) :: wp2 ! vertical velocity variance [m^2/s^2] + real(r8), pointer, dimension(:,:) :: wp3 ! third moment of vertical velocity [m^3/s^3] + real(r8), pointer, dimension(:,:) :: wpthlp ! turbulent flux of thetal [m/s K] + real(r8), pointer, dimension(:,:) :: wprtp ! turbulent flux of moisture [m/s kg/kg] + real(r8), pointer, dimension(:,:) :: rtpthlp ! covariance of thetal and qt [kg/kg K] + real(r8), pointer, dimension(:,:) :: rtp2 ! moisture variance [kg^2/kg^2] + real(r8), pointer, dimension(:,:) :: thlp2 ! temperature variance [K^2] + real(r8), pointer, dimension(:,:) :: up2 ! east-west wind variance [m^2/s^2] + real(r8), pointer, dimension(:,:) :: vp2 ! north-south wind variance [m^2/s^2] + + real(r8), pointer, dimension(:,:) :: upwp ! east-west momentum flux [m^2/s^2] + real(r8), pointer, dimension(:,:) :: vpwp ! north-south momentum flux [m^2/s^2] + real(r8), pointer, dimension(:,:) :: thlm ! mean temperature [K] + real(r8), pointer, dimension(:,:) :: rtm ! mean moisture mixing ratio [kg/kg] + real(r8), pointer, dimension(:,:) :: um ! mean east-west wind [m/s] + real(r8), pointer, dimension(:,:) :: vm ! mean north-south wind [m/s] + real(r8), pointer, dimension(:,:) :: cld ! cloud fraction [fraction] + real(r8), pointer, dimension(:,:) :: concld ! convective cloud fraction [fraction] + real(r8), pointer, dimension(:,:) :: ast ! stratiform cloud fraction [fraction] + real(r8), pointer, dimension(:,:) :: alst ! liquid stratiform cloud fraction [fraction] + real(r8), pointer, dimension(:,:) :: aist ! ice stratiform cloud fraction [fraction] + real(r8), pointer, dimension(:,:) :: qlst ! Physical in-stratus LWC [kg/kg] + real(r8), pointer, dimension(:,:) :: qist ! Physical in-stratus IWC [kg/kg] + real(r8), pointer, dimension(:,:) :: deepcu ! deep convection cloud fraction [fraction] + real(r8), pointer, dimension(:,:) :: shalcu ! shallow convection cloud fraction [fraction] + real(r8), pointer, dimension(:,:) :: khzm ! CLUBB's eddy diffusivity of heat/moisture on momentum (i.e. interface) levels [m^2/s] + real(r8), pointer, dimension(:) :: pblh ! planetary boundary layer height [m] + real(r8), pointer, dimension(:,:) :: tke ! turbulent kinetic energy [m^2/s^2] + real(r8), pointer, dimension(:,:) :: dp_icwmr ! deep convection in cloud mixing ratio [kg/kg] + real(r8), pointer, dimension(:,:) :: relvar ! relative cloud water variance [-] + real(r8), pointer, dimension(:,:) :: accre_enhan ! accretion enhancement factor [-] + real(r8), pointer, dimension(:,:) :: cmeliq + real(r8), pointer, dimension(:,:) :: cmfmc_sh ! Shallow convective mass flux--m subc (pcols,pverp) [kg/m2/s/] + + real(r8), pointer, dimension(:,:) :: qsatfac + real(r8), pointer, dimension(:,:) :: npccn + real(r8), pointer, dimension(:,:) :: prer_evap + real(r8), pointer, dimension(:,:) :: qrl + real(r8), pointer, dimension(:,:) :: radf_clubb + + ! ZM microphysics + real(r8), pointer :: dlfzm(:,:) ! ZM detrained convective cloud water mixing ratio. + real(r8), pointer :: difzm(:,:) ! ZM detrained convective cloud ice mixing ratio. + real(r8), pointer :: dnlfzm(:,:) ! ZM detrained convective cloud water num concen. + real(r8), pointer :: dnifzm(:,:) ! ZM detrained convective cloud ice num concen. + + real(r8) :: stend(pcols,pver) + real(r8) :: qvtend(pcols,pver) + real(r8) :: qctend(pcols,pver) + real(r8) :: inctend(pcols,pver) + real(r8) :: fqtend(pcols,pver) + real(r8) :: rhmini(pcols) + real(r8) :: rhmaxi(pcols) + integer :: troplev(pcols) + logical :: lqice(pcnst) + logical :: apply_to_surface + + real(r8) :: temp2d(pcols,pver), temp2dp(pcols,pverp) ! temporary array for holding scaled outputs + + integer :: nlev + + intrinsic :: max + + character(len=*), parameter :: subr='clubb_tend_cam' + +#endif + det_s(:) = 0.0_r8 + det_ice(:) = 0.0_r8 +#ifdef CLUBB_SGS + + !-----------------------------------------------------------------------------------------------! + !-----------------------------------------------------------------------------------------------! + !-----------------------------------------------------------------------------------------------! + ! MAIN COMPUTATION BEGINS HERE ! + !-----------------------------------------------------------------------------------------------! + !-----------------------------------------------------------------------------------------------! + !-----------------------------------------------------------------------------------------------! + + nlev = pver + 1 - top_lev + + frac_limit = 0.01_r8 + ic_limit = 1.e-12_r8 + + if (clubb_do_adv) then + apply_const = 1._r8 ! Initialize to one, only if CLUBB's moments are advected + else + apply_const = 0._r8 ! Never want this if CLUBB's moments are not advected + endif + + ! Get indicees for cloud and ice mass and cloud and ice number + + call cnst_get_ind('Q',ixq) + call cnst_get_ind('CLDLIQ',ixcldliq) + call cnst_get_ind('CLDICE',ixcldice) + call cnst_get_ind('NUMLIQ',ixnumliq) + call cnst_get_ind('NUMICE',ixnumice) + + ! Copy the state to state1 array to use in this routine + + ! Initialize physics tendency arrays, copy the state to state1 array to use in this routine + call physics_ptend_init(ptend_loc,state%psetcols, 'clubb', ls=.true., lu=.true., lv=.true., lq=lq) + call physics_ptend_init(ptend_all, state%psetcols, 'clubb') + + call physics_state_copy(state,state1) + + if (clubb_do_liqsupersat) then + npccn_idx = pbuf_get_index('NPCCN') + call pbuf_get_field(pbuf, npccn_idx, npccn) + endif + + ! Determine number of columns and which chunk computation is to be performed on + + ncol = state%ncol + lchnk = state%lchnk + + ! Determine time step of physics buffer + + itim_old = pbuf_old_tim_idx() + + ! Establish associations between pointers and physics buffer fields + + call pbuf_get_field(pbuf, wp2_idx, wp2, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) + call pbuf_get_field(pbuf, wp3_idx, wp3, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) + call pbuf_get_field(pbuf, wpthlp_idx, wpthlp, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) + call pbuf_get_field(pbuf, wprtp_idx, wprtp, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) + call pbuf_get_field(pbuf, rtpthlp_idx, rtpthlp, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) + call pbuf_get_field(pbuf, rtp2_idx, rtp2, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) + call pbuf_get_field(pbuf, thlp2_idx, thlp2, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) + call pbuf_get_field(pbuf, up2_idx, up2, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) + call pbuf_get_field(pbuf, vp2_idx, vp2, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) + + call pbuf_get_field(pbuf, upwp_idx, upwp, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) + call pbuf_get_field(pbuf, vpwp_idx, vpwp, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) + call pbuf_get_field(pbuf, thlm_idx, thlm, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) + call pbuf_get_field(pbuf, rtm_idx, rtm, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) + call pbuf_get_field(pbuf, um_idx, um, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) + call pbuf_get_field(pbuf, vm_idx, vm, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) + + call pbuf_get_field(pbuf, tke_idx, tke) + call pbuf_get_field(pbuf, qrl_idx, qrl) + call pbuf_get_field(pbuf, radf_idx, radf_clubb) + + call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, concld_idx, concld, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, alst_idx, alst, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, aist_idx, aist, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, qlst_idx, qlst, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, qist_idx, qist, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + + call pbuf_get_field(pbuf, qsatfac_idx, qsatfac) + + call pbuf_get_field(pbuf, prer_evap_idx, prer_evap) + call pbuf_get_field(pbuf, accre_enhan_idx, accre_enhan) + call pbuf_get_field(pbuf, cmeliq_idx, cmeliq) + call pbuf_get_field(pbuf, relvar_idx, relvar) + call pbuf_get_field(pbuf, dp_frac_idx, deepcu) + call pbuf_get_field(pbuf, sh_frac_idx, shalcu) + call pbuf_get_field(pbuf, kvh_idx, khzm) + call pbuf_get_field(pbuf, pblh_idx, pblh) + call pbuf_get_field(pbuf, icwmrdp_idx, dp_icwmr) + call pbuf_get_field(pbuf, cmfmc_sh_idx, cmfmc_sh) + + ! Initialize the apply_const variable (note special logic is due to eularian backstepping) + if (clubb_do_adv .and. (is_first_step() .or. all(wpthlp(1:ncol,1:pver) .eq. 0._r8))) then + apply_const = 0._r8 ! On first time through do not remove constant + ! from moments since it has not been added yet + endif + + ! Define the grid box size. CLUBB needs this information to determine what + ! the maximum length scale should be. This depends on the column for + ! variable mesh grids and lat-lon grids + if (single_column) then + ! If single column specify grid box size to be something + ! similar to a GCM run + grid_dx(:) = 100000._r8 + grid_dy(:) = 100000._r8 + else + + call grid_size(state1, grid_dx, grid_dy) + + endif + + ! Determine CLUBB time step and make it sub-step friendly + ! For now we want CLUBB time step to be 5 min since that is + ! what has been scientifically validated. However, there are certain + ! instances when a 5 min time step will not be possible (based on + ! host model time step or on macro-micro sub-stepping + + dtime = clubb_timestep + + ! Now check to see if dtime is greater than the host model + ! (or sub stepped) time step. If it is, then simply + ! set it equal to the host (or sub step) time step. + ! This section is mostly to deal with small host model + ! time steps (or small sub-steps) + + if (dtime .gt. hdtime) then + dtime = hdtime + endif + + ! Now check to see if CLUBB time step divides evenly into + ! the host model time step. If not, force it to divide evenly. + ! We also want it to be 5 minutes or less. This section is + ! mainly for host model time steps that are not evenly divisible + ! by 5 minutes + + if (mod(hdtime,dtime) .ne. 0) then + dtime = hdtime/2._r8 + do while (dtime .gt. clubb_timestep) + dtime = dtime/2._r8 + end do + endif + + ! If resulting host model time step and CLUBB time step do not divide evenly + ! into each other, have model throw a fit. + + if (mod(hdtime,dtime) .ne. 0) then + call endrun(subr//': CLUBB time step and HOST time step NOT compatible') + endif + + ! Since CLUBB has only been scientifically validated for a 5 minute timestep + ! (the default value of clubb_timestep), we have decided to error out if the + ! final value of dtime is less than clubb_timestep. Thus to use a non-validated + ! value for dtime the user will need to explicitly change the value of clubb_timestep + ! in the namelist, or comment this check. + if (dtime < clubb_timestep) then + if (masterproc) then + write(iulog,*) subr//':ERROR: The computed CLUBB timestep = ', dtime + write(iulog,*) subr//':ERROR: The namelist CLUBB timestep = ', clubb_timestep + write(iulog,*) ' The only validated value for the clubb timestep is 300 seconds.' + write(iulog,*) ' To run at any other value the namelist variable clubb_timestep must be set.' + write(iulog,*) ' Also consider adjusting the namelist variable cld_macmic_num_steps which' + write(iulog,*) ' determines the macro/micro substepping.' + end if + call endrun(subr//': computed CLUBB time step is less than clubb_timestep') + end if + + ! determine number of timesteps CLUBB core should be advanced, + ! host time step divided by CLUBB time step + nadv = max(hdtime/dtime,1._r8) + + ! Initialize forcings for transported scalars to zero + + sclrm_forcing(:,:) = 0._r8 + edsclrm_forcing(:,:) = 0._r8 + sclrm(:,:) = 0._r8 + + ! Compute exner function consistent with CLUBB's definition, which uses a constant + ! surface pressure. CAM's exner (in state does not). Therefore, for consistent + ! treatment with CLUBB code, anytime exner is needed to treat CLUBB variables + ! (such as thlm), use "exner_clubb" other wise use the exner in state + + do k=1,pver + do i=1,ncol + exner_clubb(i,k) = 1._r8/((state1%pmid(i,k)/p0_clubb)**(rair/cpair)) + enddo + enddo + + ! At each CLUBB call, initialize mean momentum and thermo CLUBB state + ! from the CAM state + + do k=1,pver ! loop over levels + do i=1,ncol ! loop over columns + + rtm(i,k) = state1%q(i,k,ixq)+state1%q(i,k,ixcldliq) + rvm(i,k) = state1%q(i,k,ixq) + um(i,k) = state1%u(i,k) + vm(i,k) = state1%v(i,k) + thlm(i,k) = state1%t(i,k)*exner_clubb(i,k)-(latvap/cpair)*state1%q(i,k,ixcldliq) + + if (clubb_do_adv) then + if (macmic_it .eq. 1) then + + ! Note that some of the moments below can be positive or negative. + ! Remove a constant that was added to prevent dynamics from clipping + ! them to prevent dynamics from making them positive. + thlp2(i,k) = state1%q(i,k,ixthlp2) + rtp2(i,k) = state1%q(i,k,ixrtp2) + rtpthlp(i,k) = state1%q(i,k,ixrtpthlp) - (rtpthlp_const*apply_const) + wpthlp(i,k) = state1%q(i,k,ixwpthlp) - (wpthlp_const*apply_const) + wprtp(i,k) = state1%q(i,k,ixwprtp) - (wprtp_const*apply_const) + wp2(i,k) = state1%q(i,k,ixwp2) + wp3(i,k) = state1%q(i,k,ixwp3) - (wp3_const*apply_const) + up2(i,k) = state1%q(i,k,ixup2) + vp2(i,k) = state1%q(i,k,ixvp2) + endif + endif + + enddo + enddo + + if (clubb_do_adv) then + ! If not last step of macmic loop then set apply_const back to + ! zero to prevent output from being corrupted. + if (macmic_it .eq. cld_macmic_num_steps) then + apply_const = 1._r8 + else + apply_const = 0._r8 + endif + endif + + rtm(1:ncol,pverp) = rtm(1:ncol,pver) + um(1:ncol,pverp) = state1%u(1:ncol,pver) + vm(1:ncol,pverp) = state1%v(1:ncol,pver) + thlm(1:ncol,pverp) = thlm(1:ncol,pver) + + if (clubb_do_adv) then + thlp2(1:ncol,pverp)=thlp2(1:ncol,pver) + rtp2(1:ncol,pverp)=rtp2(1:ncol,pver) + rtpthlp(1:ncol,pverp)=rtpthlp(1:ncol,pver) + wpthlp(1:ncol,pverp)=wpthlp(1:ncol,pver) + wprtp(1:ncol,pverp)=wprtp(1:ncol,pver) + wp2(1:ncol,pverp)=wp2(1:ncol,pver) + wp3(1:ncol,pverp)=wp3(1:ncol,pver) + up2(1:ncol,pverp)=up2(1:ncol,pver) + vp2(1:ncol,pverp)=vp2(1:ncol,pver) + endif + + ! Compute virtual potential temperature, which is needed for CLUBB + do k=1,pver + do i=1,ncol + thv(i,k) = state1%t(i,k)*exner_clubb(i,k)*(1._r8+zvir*state1%q(i,k,ixq)& + -state1%q(i,k,ixcldliq)) + enddo + enddo + + ! Initialize physics tendencies + call physics_ptend_init(ptend_loc,state%psetcols, 'clubb', ls=.true., lu=.true., lv=.true., lq=lq) + + call tropopause_findChemTrop(state, troplev) + + ! Loop over all columns in lchnk to advance CLUBB core + do i=1,ncol ! loop over columns + + ! Set time_elapsed to host model time step, this is for + ! CLUBB's budget stats + time_elapsed = hdtime + + ! Determine Coriolis force at given latitude. This is never used + ! when CLUBB is implemented in a host model, therefore just set + ! to zero. + fcor = 0._r8 + + ! Define the CLUBB momentum grid (in height, units of m) + do k=1,nlev+1 + zi_g(k) = state1%zi(i,pverp-k+1)-state1%zi(i,pver+1) + enddo + + ! Define the CLUBB thermodynamic grid (in units of m) + do k=1,nlev + zt_g(k+1) = state1%zm(i,pver-k+1)-state1%zi(i,pver+1) + end do + + do k=1,pver + dz_g(k) = state1%zi(i,k)-state1%zi(i,k+1) ! compute thickness + enddo + + ! Thermodynamic ghost point is below surface + zt_g(1) = -1._r8*zt_g(2) + + ! Set the elevation of the surface + sfc_elevation = state1%zi(i,pver+1) + + ! Set the grid size + host_dx = grid_dx(i) + host_dy = grid_dy(i) + + ! Compute thermodynamic stuff needed for CLUBB on thermo levels. + ! Inputs for the momentum levels are set below setup_clubb core + do k=1,nlev + p_in_Pa(k+1) = state1%pmid(i,pver-k+1) ! Pressure profile + exner(k+1) = 1._r8/exner_clubb(i,pver-k+1) + rho_ds_zt(k+1) = (1._r8/gravit)*(state1%pdel(i,pver-k+1)/dz_g(pver-k+1)) + invrs_rho_ds_zt(k+1) = 1._r8/(rho_ds_zt(k+1)) ! Inverse ds rho at thermo + rho_in(k+1) = rho_ds_zt(k+1) ! rho on thermo + thv_ds_zt(k+1) = thv(i,pver-k+1) ! thetav on thermo + rfrzm(k+1) = state1%q(i,pver-k+1,ixcldice) + radf(k+1) = radf_clubb(i,pver-k+1) + qrl_clubb(k+1) = qrl(i,pver-k+1)/(cpair*state1%pdel(i,pver-k+1)) + enddo + + ! Below computes the same stuff for the ghost point. May or may + ! not be needed, just to be safe to avoid NaN's + rho_ds_zt(1) = rho_ds_zt(2) + invrs_rho_ds_zt(1) = invrs_rho_ds_zt(2) + rho_in(1) = rho_ds_zt(2) + thv_ds_zt(1) = thv_ds_zt(2) + rho_zt(:) = rho_in(:) + p_in_Pa(1) = p_in_Pa(2) + exner(1) = exner(2) + rfrzm(1) = rfrzm(2) + radf(1) = radf(2) + qrl_clubb(1) = qrl_clubb(2) + + ! Compute mean w wind on thermo grid, convert from omega to w + wm_zt(1) = 0._r8 + do k=1,nlev + wm_zt(k+1) = -1._r8*state1%omega(i,pver-k+1)/(rho_in(k+1)*gravit) + enddo + + ! ------------------------------------------------- ! + ! Begin case specific code for SCAM cases. ! + ! This section of code block NOT called in ! + ! global simulations ! + ! ------------------------------------------------- ! + + if (single_column) then + + ! Initialize zo if variable ustar is used + + if (cam_in%landfrac(i) .ge. 0.5_r8) then + zo = 0.035_r8 + else + zo = 0.0001_r8 + endif + + ! Compute surface wind (ubar) + ubar = sqrt(um(i,pver)**2+vm(i,pver)**2) + if (ubar .lt. 0.25_r8) ubar = 0.25_r8 + + ! Below denotes case specifics for surface momentum + ! and thermodynamic fluxes, depending on the case + + ! Define ustar (based on case, if not variable) + ustar = 0.25_r8 ! Initialize ustar in case no case + + if(trim(scm_clubb_iop_name) .eq. 'BOMEX_5day') then + ustar = 0.28_r8 + endif + + if(trim(scm_clubb_iop_name) .eq. 'ATEX_48hr') then + ustar = 0.30_r8 + endif + + if(trim(scm_clubb_iop_name) .eq. 'RICO_3day') then + ustar = 0.28_r8 + endif + + if(trim(scm_clubb_iop_name) .eq. 'arm97' .or. trim(scm_clubb_iop_name) .eq. 'gate' .or. & + trim(scm_clubb_iop_name) .eq. 'toga' .or. trim(scm_clubb_iop_name) .eq. 'mpace' .or. & + trim(scm_clubb_iop_name) .eq. 'ARM_CC') then + + bflx22 = (gravit/theta0)*wpthlp_sfc + ustar = diag_ustar(zt_g(2),bflx22,ubar,zo) + endif + + ! Compute the surface momentum fluxes, if this is a SCAM simulation + upwp_sfc = -um(i,pver)*ustar**2/ubar + vpwp_sfc = -vm(i,pver)*ustar**2/ubar + + endif + + ! Define surface sources for transported variables for diffusion, will + ! be zero as these tendencies are done in vertical_diffusion + do ixind=1,edsclr_dim + wpedsclrp_sfc(ixind) = 0._r8 + enddo + + ! Define forcings from CAM to CLUBB as zero for momentum and thermo, + ! forcings already applied through CAM + thlm_forcing = 0._r8 + rtm_forcing = 0._r8 + um_forcing = 0._r8 + vm_forcing = 0._r8 + + wprtp_forcing = 0._r8 + wpthlp_forcing = 0._r8 + rtp2_forcing = 0._r8 + thlp2_forcing = 0._r8 + rtpthlp_forcing = 0._r8 + + ice_supersat_frac = 0._r8 + + ! Set stats output and increment equal to CLUBB and host dt + stats_tsamp = dtime + stats_tout = hdtime + + ! Heights need to be set at each timestep. Therefore, recall + ! setup_grid and setup_parameters for this. + + ! Read in parameters for CLUBB. Just read in default values + call read_parameters_api( -99, "", clubb_params ) + + ! Set-up CLUBB core at each CLUBB call because heights can change + call setup_grid_heights_api(l_implemented, grid_type, zi_g(2), & + zi_g(1), zi_g, zt_g) + + call setup_parameters_api(zi_g(2), clubb_params, nlev+1, grid_type, & + zi_g, zt_g, err_code) + + ! Compute some inputs from the thermodynamic grid + ! to the momentum grid + rho_ds_zm = zt2zm_api(rho_ds_zt) + rho_zm = zt2zm_api(rho_zt) + invrs_rho_ds_zm = zt2zm_api(invrs_rho_ds_zt) + thv_ds_zm = zt2zm_api(thv_ds_zt) + wm_zm = zt2zm_api(wm_zt) + + ! Surface fluxes provided by host model + wpthlp_sfc = cam_in%shf(i)/(cpair*rho_ds_zm(1)) ! Sensible heat flux + wprtp_sfc = cam_in%cflx(i,1)/rho_ds_zm(1) ! Moisture flux (check rho) + upwp_sfc = cam_in%wsx(i)/rho_ds_zm(1) ! Surface meridional momentum flux + vpwp_sfc = cam_in%wsy(i)/rho_ds_zm(1) ! Surface zonal momentum flux + + ! Need to flip arrays around for CLUBB core + do k=1,nlev+1 + um_in(k) = um(i,pverp-k+1) + vm_in(k) = vm(i,pverp-k+1) + upwp_in(k) = upwp(i,pverp-k+1) + vpwp_in(k) = vpwp(i,pverp-k+1) + up2_in(k) = up2(i,pverp-k+1) + vp2_in(k) = vp2(i,pverp-k+1) + wp2_in(k) = wp2(i,pverp-k+1) + wp3_in(k) = wp3(i,pverp-k+1) + rtp2_in(k) = rtp2(i,pverp-k+1) + thlp2_in(k) = thlp2(i,pverp-k+1) + thlm_in(k) = thlm(i,pverp-k+1) + rtm_in(k) = rtm(i,pverp-k+1) + rvm_in(k) = rvm(i,pverp-k+1) + wprtp_in(k) = wprtp(i,pverp-k+1) + wpthlp_in(k) = wpthlp(i,pverp-k+1) + rtpthlp_in(k) = rtpthlp(i,pverp-k+1) + + if (k .ne. 1) then + pre_in(k) = prer_evap(i,pverp-k+1) + endif + + ! Initialize these to prevent crashing behavior + rcm_out(k) = 0._r8 + wprcp_out(k) = 0._r8 + cloud_frac_out(k) = 0._r8 + rcm_in_layer_out(k) = 0._r8 + cloud_cover_out(k) = 0._r8 + edsclr_in(k,:) = 0._r8 + khzm_out(k) = 0._r8 + khzt_out(k) = 0._r8 + + ! higher order scalar stuff, put to zero + sclrm(k,:) = 0._r8 + wpsclrp(k,:) = 0._r8 + sclrp2(k,:) = 0._r8 + sclrprtp(k,:) = 0._r8 + sclrpthlp(k,:) = 0._r8 + wpsclrp_sfc(:) = 0._r8 + hydromet(k,:) = 0._r8 + wphydrometp(k,:) = 0._r8 + wp2hmp(k,:) = 0._r8 + rtphmp_zt(k,:) = 0._r8 + thlphmp_zt(k,:) = 0._r8 + + enddo + + pre_in(1) = pre_in(2) + + if (clubb_do_adv) then + if (macmic_it .eq. 1) then + wp2_in=zt2zm_api(wp2_in) + wpthlp_in=zt2zm_api(wpthlp_in) + wprtp_in=zt2zm_api(wprtp_in) + up2_in=zt2zm_api(up2_in) + vp2_in=zt2zm_api(vp2_in) + thlp2_in=zt2zm_api(thlp2_in) + rtp2_in=zt2zm_api(rtp2_in) + rtpthlp_in=zt2zm_api(rtpthlp_in) + + do k=1,nlev+1 + thlp2_in(k)=max(thl_tol**2,thlp2_in(k)) + rtp2_in(k)=max(rt_tol**2,rtp2_in(k)) + wp2_in(k)=max(w_tol_sqd,wp2_in(k)) + up2_in(k)=max(w_tol_sqd,up2_in(k)) + vp2_in(k)=max(w_tol_sqd,vp2_in(k)) + enddo + endif + endif + + ! rtp3_in and thlp3_in are not currently used in CLUBB's default code. + rtp3_in(:) = 0.0_r8 + thlp3_in(:) = 0.0_r8 + + ! Do the same for tracers + icnt=0 + do ixind=1,pcnst + if (lq(ixind)) then + icnt=icnt+1 + do k=1,nlev + edsclr_in(k+1,icnt) = state1%q(i,pver-k+1,ixind) + enddo + edsclr_in(1,icnt) = edsclr_in(2,icnt) + end if + enddo + + if (do_expldiff) then + do k=1,nlev + edsclr_in(k+1,icnt+1) = thlm(i,pver-k+1) + edsclr_in(k+1,icnt+2) = rtm(i,pver-k+1) + enddo + + edsclr_in(1,icnt+1) = edsclr_in(2,icnt+1) + edsclr_in(1,icnt+2) = edsclr_in(2,icnt+2) + endif + + do t=1,nadv ! do needed number of "sub" timesteps for each CAM step + + ! Increment the statistics then being stats timestep + if (l_stats) then + time_elapsed = time_elapsed+dtime + call stats_begin_timestep_api(time_elapsed, 1, 1) + endif + + ! Advance CLUBB CORE one timestep in the future + call advance_clubb_core_api & + ( l_implemented, dtime, fcor, sfc_elevation, hydromet_dim, & + thlm_forcing, rtm_forcing, um_forcing, vm_forcing, & + sclrm_forcing, edsclrm_forcing, wprtp_forcing, & + wpthlp_forcing, rtp2_forcing, thlp2_forcing, & + rtpthlp_forcing, wm_zm, wm_zt, & + wpthlp_sfc, wprtp_sfc, upwp_sfc, vpwp_sfc, & + wpsclrp_sfc, wpedsclrp_sfc, & + p_in_Pa, rho_zm, rho_in, exner, & + rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & + invrs_rho_ds_zt, thv_ds_zm, thv_ds_zt, hydromet, & + rfrzm, radf, & + wphydrometp, wp2hmp, rtphmp_zt, thlphmp_zt, & + host_dx, host_dy, & + um_in, vm_in, upwp_in, & + vpwp_in, up2_in, vp2_in, & + thlm_in, rtm_in, wprtp_in, wpthlp_in, & + wp2_in, wp3_in, rtp2_in, rtp3_in, & + thlp2_in, thlp3_in, rtpthlp_in, & + sclrm, sclrp2, sclrprtp, sclrpthlp, & + wpsclrp, edsclr_in, err_code, & + rcm_out, wprcp_out, cloud_frac_out, ice_supersat_frac, & + rcm_in_layer_out, cloud_cover_out, & + khzm_out, khzt_out, qclvar_out, thlprcp_out, & + pdf_params) + + if (do_rainturb) then + rvm_in = rtm_in - rcm_out + call update_xp2_mc_api(nlev+1, dtime, cloud_frac_out, & + rcm_out, rvm_in, thlm_in, wm_zt, exner, pre_in, pdf_params, & + rtp2_mc_out, thlp2_mc_out, & + wprtp_mc_out, wpthlp_mc_out, & + rtpthlp_mc_out) + + dum1 = (1._r8 - cam_in%landfrac(i)) + + ! update turbulent moments based on rain evaporation + rtp2_in = rtp2_in + clubb_rnevap_effic * dum1 * rtp2_mc_out * dtime + thlp2_in = thlp2_in + clubb_rnevap_effic * dum1 * thlp2_mc_out * dtime + wprtp_in = wprtp_in + clubb_rnevap_effic * dum1 * wprtp_mc_out * dtime + wpthlp_in = wpthlp_in + clubb_rnevap_effic * dum1 * wpthlp_mc_out * dtime + endif + + if (do_cldcool) then + + rcm_out_zm = zt2zm_api(rcm_out) + qrl_zm = zt2zm_api(qrl_clubb) + thlp2_rad_out(:) = 0._r8 + call calculate_thlp2_rad_api(nlev+1, rcm_out_zm, thlprcp_out, qrl_zm, thlp2_rad_out) + thlp2_in = thlp2_in + thlp2_rad_out * dtime + thlp2_in = max(thl_tol**2,thlp2_in) + endif + + ! Check to see if stats should be output, here stats are read into + ! output arrays to make them conformable to CAM output + if (l_stats) call stats_end_timestep_clubb(i,out_zt,out_zm,& + out_radzt,out_radzm,out_sfc) + + enddo ! end time loop + + if (clubb_do_adv) then + if (macmic_it .eq. cld_macmic_num_steps) then + wp2_in=zm2zt_api(wp2_in) + wpthlp_in=zm2zt_api(wpthlp_in) + wprtp_in=zm2zt_api(wprtp_in) + up2_in=zm2zt_api(up2_in) + vp2_in=zm2zt_api(vp2_in) + thlp2_in=zm2zt_api(thlp2_in) + rtp2_in=zm2zt_api(rtp2_in) + rtpthlp_in=zm2zt_api(rtpthlp_in) + + do k=1,nlev+1 + thlp2_in(k)=max(thl_tol**2,thlp2_in(k)) + rtp2_in(k)=max(rt_tol**2,rtp2_in(k)) + wp2_in(k)=max(w_tol_sqd,wp2_in(k)) + up2_in(k)=max(w_tol_sqd,up2_in(k)) + vp2_in(k)=max(w_tol_sqd,vp2_in(k)) + enddo + endif + endif + + ! Arrays need to be "flipped" to CAM grid + do k=1,nlev+1 + + um(i,pverp-k+1) = um_in(k) + vm(i,pverp-k+1) = vm_in(k) + upwp(i,pverp-k+1) = upwp_in(k) + vpwp(i,pverp-k+1) = vpwp_in(k) + up2(i,pverp-k+1) = up2_in(k) + vp2(i,pverp-k+1) = vp2_in(k) + thlm(i,pverp-k+1) = thlm_in(k) + rtm(i,pverp-k+1) = rtm_in(k) + wprtp(i,pverp-k+1)= wprtp_in(k) + wpthlp(i,pverp-k+1) = wpthlp_in(k) + wp2(i,pverp-k+1) = wp2_in(k) + wp3(i,pverp-k+1) = wp3_in(k) + rtp2(i,pverp-k+1) = rtp2_in(k) + thlp2(i,pverp-k+1)= thlp2_in(k) + rtpthlp(i,pverp-k+1) = rtpthlp_in(k) + rcm(i,pverp-k+1) = rcm_out(k) + wprcp(i,pverp-k+1)= wprcp_out(k) + cloud_frac(i,pverp-k+1) = min(cloud_frac_out(k),1._r8) + rcm_in_layer(i,pverp-k+1) = rcm_in_layer_out(k) + zt_out(i,pverp-k+1) = zt_g(k) + zi_out(i,pverp-k+1) = zi_g(k) + khzm(i,pverp-k+1) = khzm_out(k) + qclvar(i,pverp-k+1) = min(1._r8,qclvar_out(k)) + + do ixind=1,edsclr_dim + edsclr_out(pverp-k+1,ixind) = edsclr_in(k,ixind) + enddo + + enddo + + ! Values to use above top_lev, for variables that have not already been + ! set up there. These are mostly fill values that should not actually be + ! used in the run, but may end up in diagnostic output. + upwp(i,:top_lev-1) = 0._r8 + vpwp(i,:top_lev-1) = 0._r8 + rcm(i,:top_lev-1) = 0._r8 + wprcp(i,:top_lev-1) = 0._r8 + cloud_frac(i,:top_lev-1) = 0._r8 + rcm_in_layer(i,:top_lev-1) = 0._r8 + zt_out(i,:top_lev-1) = 0._r8 + zi_out(i,:top_lev-1) = 0._r8 + khzm(i,:top_lev-1) = 0._r8 + qclvar(i,:top_lev-1) = 2._r8 + + ! enforce zero tracer tendencies above the top_lev level -- no change + icnt=0 + do ixind=1,pcnst + if (lq(ixind)) then + icnt=icnt+1 + edsclr_out(:top_lev-1,icnt) = state1%q(i,:top_lev-1,ixind) + end if + enddo + + ! Fill up arrays needed for McICA. Note we do not want the ghost point, + ! thus why the second loop is needed. + + zi_out(i,1) = 0._r8 + + ! Section below is concentrated on energy fixing for conservation. + ! There are two steps to this process. The first is to remove any tendencies + ! CLUBB may have produced above where it is active due to roundoff. + ! The second is to provider a fixer because CLUBB and CAM's thermodynamic + ! variables are different. + + ! Initialize clubbtop with the chemistry topopause top, to prevent CLUBB from + ! firing up in the stratosphere + clubbtop = troplev(i) + do while ((rtp2(i,clubbtop) .le. 1.e-15_r8 .and. rcm(i,clubbtop) .eq. 0._r8) .and. clubbtop .lt. pver-1) + clubbtop = clubbtop + 1 + enddo + + ! Compute static energy using CLUBB's variables + do k=1,pver + clubb_s(k) = cpair*((thlm(i,k)+(latvap/cpair)*rcm(i,k))/exner_clubb(i,k))+ & + gravit*state1%zm(i,k)+state1%phis(i) + enddo + + ! Compute integrals above layer where CLUBB is active + se_upper_a = 0._r8 ! energy in layers above where CLUBB is active AFTER CLUBB is called + se_upper_b = 0._r8 ! energy in layers above where CLUBB is active BEFORE CLUBB is called + tw_upper_a = 0._r8 ! total water in layers above where CLUBB is active AFTER CLUBB is called + tw_upper_b = 0._r8 ! total water in layers above where CLUBB is active BEFORE CLUBB is called + do k=1,clubbtop + se_upper_a = se_upper_a + (clubb_s(k)+0.5_r8*(um(i,k)**2+vm(i,k)**2)+(latvap+latice)* & + (rtm(i,k)-rcm(i,k))+(latice)*rcm(i,k))*state1%pdel(i,k)/gravit + se_upper_b = se_upper_b + (state1%s(i,k)+0.5_r8*(state1%u(i,k)**2+state1%v(i,k)**2)+(latvap+latice)* & + state1%q(i,k,ixq)+(latice)*state1%q(i,k,ixcldliq))*state1%pdel(i,k)/gravit + tw_upper_a = tw_upper_a + rtm(i,k)*state1%pdel(i,k)/gravit + tw_upper_b = tw_upper_b + (state1%q(i,k,ixq)+state1%q(i,k,ixcldliq))*state1%pdel(i,k)/gravit + enddo + + ! Compute the disbalance of total energy and water in upper levels, + ! divide by the thickness in the lower atmosphere where we will + ! evenly distribute this disbalance + se_upper_diss = (se_upper_a - se_upper_b)/(state1%pint(i,pverp)-state1%pint(i,clubbtop+1)) + tw_upper_diss = (tw_upper_a - tw_upper_b)/(state1%pint(i,pverp)-state1%pint(i,clubbtop+1)) + + ! Perform a test to see if there will be any negative RTM errors + ! in the column. If so, apply the disbalance to the surface + apply_to_surface = .false. + if (tw_upper_diss .lt. 0._r8) then + do k=clubbtop+1,pver + rtm_test = (rtm(i,k) + tw_upper_diss*gravit) - rcm(i,k) + if (rtm_test .lt. 0._r8) then + apply_to_surface = .true. + endif + enddo + endif + + if (apply_to_surface) then + tw_upper_diss = (tw_upper_a - tw_upper_b)/(state1%pint(i,pverp)-state1%pint(i,pver)) + se_upper_diss = (se_upper_a - se_upper_b)/(state1%pint(i,pverp)-state1%pint(i,pver)) + rtm(i,pver) = rtm(i,pver) + tw_upper_diss*gravit + if (apply_to_heat) clubb_s(pver) = clubb_s(pver) + se_upper_diss*gravit + else + ! Apply the disbalances above to layers where CLUBB is active + do k=clubbtop+1,pver + rtm(i,k) = rtm(i,k) + tw_upper_diss*gravit + if (apply_to_heat) clubb_s(k) = clubb_s(k) + se_upper_diss*gravit + enddo + endif + + ! Essentially "zero" out tendencies in the layers above where CLUBB is active + do k=1,clubbtop + if (apply_to_heat) clubb_s(k) = state1%s(i,k) + rcm(i,k) = state1%q(i,k,ixcldliq) + rtm(i,k) = state1%q(i,k,ixq) + rcm(i,k) + enddo + + ! Compute integrals for static energy, kinetic energy, water vapor, and liquid water + ! after CLUBB is called. + se_a = 0._r8 + ke_a = 0._r8 + wv_a = 0._r8 + wl_a = 0._r8 + + ! Do the same as above, but for before CLUBB was called. + se_b = 0._r8 + ke_b = 0._r8 + wv_b = 0._r8 + wl_b = 0._r8 + do k=1,pver + se_a(i) = se_a(i) + clubb_s(k)*state1%pdel(i,k)/gravit + ke_a(i) = ke_a(i) + 0.5_r8*(um(i,k)**2+vm(i,k)**2)*state1%pdel(i,k)/gravit + wv_a(i) = wv_a(i) + (rtm(i,k)-rcm(i,k))*state1%pdel(i,k)/gravit + wl_a(i) = wl_a(i) + (rcm(i,k))*state1%pdel(i,k)/gravit + + se_b(i) = se_b(i) + state1%s(i,k)*state1%pdel(i,k)/gravit + ke_b(i) = ke_b(i) + 0.5_r8*(state1%u(i,k)**2+state1%v(i,k)**2)*state1%pdel(i,k)/gravit + wv_b(i) = wv_b(i) + state1%q(i,k,ixq)*state1%pdel(i,k)/gravit + wl_b(i) = wl_b(i) + state1%q(i,k,ixcldliq)*state1%pdel(i,k)/gravit + enddo + + ! Based on these integrals, compute the total energy before and after CLUBB call + te_a(i) = se_a(i) + ke_a(i) + (latvap+latice)*wv_a(i)+latice*wl_a(i) + te_b(i) = se_b(i) + ke_b(i) + (latvap+latice)*wv_b(i)+latice*wl_b(i) + + ! Take into account the surface fluxes of heat and moisture + ! Use correct qflux from cam_in, not lhf/latvap as was done previously + te_b(i) = te_b(i)+(cam_in%shf(i)+cam_in%cflx(i,1)*(latvap+latice))*hdtime + + ! Compute the disbalance of total energy, over depth where CLUBB is active + se_dis = (te_a(i) - te_b(i))/(state1%pint(i,pverp)-state1%pint(i,clubbtop+1)) + + ! Fix the total energy coming out of CLUBB so it achieves enery conservation. + ! Apply this fixer throughout the column evenly, but only at layers where + ! CLUBB is active. + ! + ! NOTE: The energy fixer seems to cause the climate to change significantly + ! when using specified dynamics, so allow this to be turned off via a namelist + ! variable. + if (clubb_do_energyfix) then + do k=clubbtop+1,pver + clubb_s(k) = clubb_s(k) - se_dis*gravit + enddo + endif + + ! Now compute the tendencies of CLUBB to CAM, note that pverp is the ghost point + ! for all variables and therefore is never called in this loop + do k=1,pver + + ptend_loc%u(i,k) = (um(i,k)-state1%u(i,k))/hdtime ! east-west wind + ptend_loc%v(i,k) = (vm(i,k)-state1%v(i,k))/hdtime ! north-south wind + ptend_loc%q(i,k,ixq) = (rtm(i,k)-rcm(i,k)-state1%q(i,k,ixq))/hdtime ! water vapor + ptend_loc%q(i,k,ixcldliq) = (rcm(i,k)-state1%q(i,k,ixcldliq))/hdtime ! Tendency of liquid water + ptend_loc%s(i,k) = (clubb_s(k)-state1%s(i,k))/hdtime ! Tendency of static energy + + if (clubb_do_adv) then + if (macmic_it .eq. cld_macmic_num_steps) then + + ! Here add a constant to moments which can be either positive or + ! negative. This is to prevent clipping when dynamics tries to + ! make all constituents positive + wp3(i,k) = wp3(i,k) + wp3_const + rtpthlp(i,k) = rtpthlp(i,k) + rtpthlp_const + wpthlp(i,k) = wpthlp(i,k) + wpthlp_const + wprtp(i,k) = wprtp(i,k) + wprtp_const + + ptend_loc%q(i,k,ixthlp2)=(thlp2(i,k)-state1%q(i,k,ixthlp2))/hdtime ! THLP Variance + ptend_loc%q(i,k,ixrtp2)=(rtp2(i,k)-state1%q(i,k,ixrtp2))/hdtime ! RTP Variance + ptend_loc%q(i,k,ixrtpthlp)=(rtpthlp(i,k)-state1%q(i,k,ixrtpthlp))/hdtime ! RTP THLP covariance + ptend_loc%q(i,k,ixwpthlp)=(wpthlp(i,k)-state1%q(i,k,ixwpthlp))/hdtime ! WPTHLP + ptend_loc%q(i,k,ixwprtp)=(wprtp(i,k)-state1%q(i,k,ixwprtp))/hdtime ! WPRTP + ptend_loc%q(i,k,ixwp2)=(wp2(i,k)-state1%q(i,k,ixwp2))/hdtime ! WP2 + ptend_loc%q(i,k,ixwp3)=(wp3(i,k)-state1%q(i,k,ixwp3))/hdtime ! WP3 + ptend_loc%q(i,k,ixup2)=(up2(i,k)-state1%q(i,k,ixup2))/hdtime ! UP2 + ptend_loc%q(i,k,ixvp2)=(vp2(i,k)-state1%q(i,k,ixvp2))/hdtime ! VP2 + else + ptend_loc%q(i,k,ixthlp2)=0._r8 + ptend_loc%q(i,k,ixrtp2)=0._r8 + ptend_loc%q(i,k,ixrtpthlp)=0._r8 + ptend_loc%q(i,k,ixwpthlp)=0._r8 + ptend_loc%q(i,k,ixwprtp)=0._r8 + ptend_loc%q(i,k,ixwp2)=0._r8 + ptend_loc%q(i,k,ixwp3)=0._r8 + ptend_loc%q(i,k,ixup2)=0._r8 + ptend_loc%q(i,k,ixvp2)=0._r8 + endif + + endif + + ! Apply tendencies to ice mixing ratio, liquid and ice number, and aerosol constituents. + ! Loading up this array doesn't mean the tendencies are applied. + ! edsclr_out is compressed with just the constituents being used, ptend and state are not compressed + + icnt=0 + do ixind=1,pcnst + if (lq(ixind)) then + icnt=icnt+1 + if ((ixind /= ixq) .and. (ixind /= ixcldliq) .and.& + (ixind /= ixthlp2) .and. (ixind /= ixrtp2) .and.& + (ixind /= ixrtpthlp) .and. (ixind /= ixwpthlp) .and.& + (ixind /= ixwprtp) .and. (ixind /= ixwp2) .and.& + (ixind /= ixwp3) .and. (ixind /= ixup2) .and. (ixind /= ixvp2) ) then + ptend_loc%q(i,k,ixind) = (edsclr_out(k,icnt)-state1%q(i,k,ixind))/hdtime ! transported constituents + end if + end if + enddo + + enddo + + + enddo ! end column loop + + call outfld('KVH_CLUBB', khzm, pcols, lchnk) + + ! Add constant to ghost point so that output is not corrupted + if (clubb_do_adv) then + if (macmic_it .eq. cld_macmic_num_steps) then + wp3(:,pverp) = wp3(:,pverp) + wp3_const + rtpthlp(:,pverp) = rtpthlp(:,pverp) + rtpthlp_const + wpthlp(:,pverp) = wpthlp(:,pverp) + wpthlp_const + wprtp(:,pverp) = wprtp(:,pverp) + wprtp_const + endif + endif + + cmeliq(:,:) = ptend_loc%q(:,:,ixcldliq) + + ! ------------------------------------------------- ! + ! End column computation of CLUBB, begin to apply ! + ! and compute output, etc ! + ! ------------------------------------------------- ! + + ! Output CLUBB tendencies + call outfld( 'RVMTEND_CLUBB', ptend_loc%q(:,:,ixq), pcols, lchnk) + call outfld( 'RCMTEND_CLUBB', ptend_loc%q(:,:,ixcldliq), pcols, lchnk) + call outfld( 'RIMTEND_CLUBB', ptend_loc%q(:,:,ixcldice), pcols, lchnk) + call outfld( 'STEND_CLUBB', ptend_loc%s,pcols, lchnk) + call outfld( 'UTEND_CLUBB', ptend_loc%u,pcols, lchnk) + call outfld( 'VTEND_CLUBB', ptend_loc%v,pcols, lchnk) + + call outfld( 'CMELIQ', cmeliq, pcols, lchnk) + + ! Update physics tendencies + call physics_ptend_sum(ptend_loc,ptend_all,ncol) + call physics_update(state1,ptend_loc,hdtime) + + ! Due to the order of operation of CLUBB, which closes on liquid first, + ! then advances it's predictive equations second, this can lead to + ! RHliq > 1 directly before microphysics is called. Therefore, we use + ! ice_macro_tend to enforce RHliq <= 1 everywhere before microphysics is called. + + if (clubb_do_liqsupersat) then + + ! -------------------------------------- ! + ! Ice Saturation Adjustment Computation ! + ! -------------------------------------- ! + + latsub = latvap + latice + + lq2(:) = .FALSE. + lq2(ixq) = .TRUE. + lq2(ixcldliq) = .TRUE. + lq2(ixnumliq) = .TRUE. + + call physics_ptend_init(ptend_loc, state%psetcols, 'iceadj', ls=.true., lq=lq2 ) + + stend(:ncol,:)=0._r8 + qvtend(:ncol,:)=0._r8 + qctend(:ncol,:)=0._r8 + inctend(:ncol,:)=0._r8 + + call liquid_macro_tend(npccn(:ncol,top_lev:pver),state1%t(:ncol,top_lev:pver), & + state1%pmid(:ncol,top_lev:pver),state1%q(:ncol,top_lev:pver,ixq),state1%q(:ncol,top_lev:pver,ixcldliq),& + state1%q(:ncol,top_lev:pver,ixnumliq),latvap,hdtime,& + stend(:ncol,top_lev:pver),qvtend(:ncol,top_lev:pver),qctend(:ncol,top_lev:pver),& + inctend(:ncol,top_lev:pver)) + + ! update local copy of state with the tendencies + ptend_loc%q(:ncol,top_lev:pver,ixq)=qvtend(:ncol,top_lev:pver) + ptend_loc%q(:ncol,top_lev:pver,ixcldliq)=qctend(:ncol,top_lev:pver) + ptend_loc%q(:ncol,top_lev:pver,ixnumliq)=inctend(:ncol,top_lev:pver) + ptend_loc%s(:ncol,top_lev:pver)=stend(:ncol,top_lev:pver) + + ! Add the ice tendency to the output tendency + call physics_ptend_sum(ptend_loc, ptend_all, ncol) + + ! ptend_loc is reset to zero by this call + call physics_update(state1, ptend_loc, hdtime) + + ! Write output for tendencies: + ! oufld: QVTENDICE,QCTENDICE,NCTENDICE,FQTENDICE + call outfld( 'TTENDICE', stend/cpair, pcols, lchnk ) + call outfld( 'QVTENDICE', qvtend, pcols, lchnk ) + call outfld( 'QCTENDICE', qctend, pcols, lchnk ) + call outfld( 'NCTENDICE', inctend, pcols, lchnk ) + + where(qctend .ne. 0._r8) + fqtend = 1._r8 + elsewhere + fqtend = 0._r8 + end where + + call outfld( 'FQTENDICE', fqtend, pcols, lchnk ) + end if + + ! ------------------------------------------------------------ ! + ! ------------------------------------------------------------ ! + ! ------------------------------------------------------------ ! + ! The rest of the code deals with diagnosing variables ! + ! for microphysics/radiation computation and macrophysics ! + ! ------------------------------------------------------------ ! + ! ------------------------------------------------------------ ! + ! ------------------------------------------------------------ ! + + + ! --------------------------------------------------------------------------------- ! + ! COMPUTE THE ICE CLOUD DETRAINMENT ! + ! Detrainment of convective condensate into the environment or stratiform cloud ! + ! --------------------------------------------------------------------------------- ! + + ! Initialize the shallow convective detrainment rate, will always be zero + dlf2(:,:) = 0.0_r8 + + lqice(:) = .false. + lqice(ixcldliq) = .true. + lqice(ixcldice) = .true. + lqice(ixnumliq) = .true. + lqice(ixnumice) = .true. + + call physics_ptend_init(ptend_loc,state%psetcols, 'clubb', ls=.true., lq=lqice) + + if (zmconv_microp) then + call pbuf_get_field(pbuf, dlfzm_idx, dlfzm) + call pbuf_get_field(pbuf, difzm_idx, difzm) + call pbuf_get_field(pbuf, dnlfzm_idx, dnlfzm) + call pbuf_get_field(pbuf, dnifzm_idx, dnifzm) + end if + ! shofer change detrainment temperature ramp + ! this changes the phase at which all is liq/ice + do k=1,pver + do i=1,ncol + if( state1%t(i,k) > 243.15_r8 ) then + dum1 = 0.0_r8 + elseif ( state1%t(i,k) < 238.15_r8 ) then + dum1 = 1.0_r8 + else + dum1 = ( 243.15_r8 - state1%t(i,k) ) / 5._r8 + endif + + if (zmconv_microp) then + ptend_loc%q(i,k,ixcldliq) = dlfzm(i,k) + dlf2(i,k) * ( 1._r8 - dum1 ) + ptend_loc%q(i,k,ixcldice) = difzm(i,k) + dlf2(i,k) * dum1 + + ptend_loc%q(i,k,ixnumliq) = dnlfzm(i,k) + 3._r8 * ( dlf2(i,k) * ( 1._r8 - dum1 ) ) & + / (4._r8*3.14_r8*10.e-6_r8**3*997._r8) ! Shallow Convection + ptend_loc%q(i,k,ixnumice) = dnifzm(i,k) + 3._r8 * ( dlf2(i,k) * dum1 ) & + / (4._r8*3.14_r8*50.e-6_r8**3*500._r8) ! Shallow Convection + ptend_loc%s(i,k) = dlf2(i,k) * dum1 * latice + else + + ptend_loc%q(i,k,ixcldliq) = dlf(i,k) * ( 1._r8 - dum1 ) + ptend_loc%q(i,k,ixcldice) = dlf(i,k) * dum1 + ptend_loc%q(i,k,ixnumliq) = 3._r8 * ( max(0._r8, ( dlf(i,k) - dlf2(i,k) )) * ( 1._r8 - dum1 ) ) & + / (4._r8*3.14_r8* 8.e-6_r8**3*997._r8) + & ! Deep Convection + 3._r8 * ( dlf2(i,k) * ( 1._r8 - dum1 ) ) & + / (4._r8*3.14_r8*10.e-6_r8**3*997._r8) ! Shallow Convection + ptend_loc%q(i,k,ixnumice) = 3._r8 * ( max(0._r8, ( dlf(i,k) - dlf2(i,k) )) * dum1 ) & + / (4._r8*3.14_r8*25.e-6_r8**3*500._r8) + & ! Deep Convection + 3._r8 * ( dlf2(i,k) * dum1 ) & + / (4._r8*3.14_r8*50.e-6_r8**3*500._r8) ! Shallow Convection + ptend_loc%s(i,k) = dlf(i,k) * dum1 * latice + end if + + ! Only rliq is saved from deep convection, which is the reserved liquid. We need to keep + ! track of the integrals of ice and static energy that is effected from conversion to ice + ! so that the energy checker doesn't complain. + det_s(i) = det_s(i) + ptend_loc%s(i,k)*state1%pdel(i,k)/gravit + det_ice(i) = det_ice(i) - ptend_loc%q(i,k,ixcldice)*state1%pdel(i,k)/gravit + + enddo + enddo + + det_ice(:ncol) = det_ice(:ncol)/1000._r8 ! divide by density of water + + call outfld( 'DPDLFLIQ', ptend_loc%q(:,:,ixcldliq), pcols, lchnk) + call outfld( 'DPDLFICE', ptend_loc%q(:,:,ixcldice), pcols, lchnk) + + temp2dp(:ncol,:pver) = ptend_loc%s(:ncol,:pver)/cpair + call outfld( 'DPDLFT', temp2dp, pcols, lchnk) + + call physics_ptend_sum(ptend_loc,ptend_all,ncol) + call physics_update(state1,ptend_loc,hdtime) + + ! ------------------------------------------------- ! + ! Diagnose relative cloud water variance ! + ! ------------------------------------------------- ! + + if (deep_scheme .eq. 'CLUBB_SGS') then + relvarmax = 2.0_r8 + else + relvarmax = 10.0_r8 + endif + + relvar(:,:) = relvarmax ! default + + if (deep_scheme .ne. 'CLUBB_SGS') then + where (rcm(:ncol,:pver) /= 0 .and. qclvar(:ncol,:pver) /= 0) & + relvar(:ncol,:pver) = min(relvarmax,max(0.001_r8,rcm(:ncol,:pver)**2/qclvar(:ncol,:pver))) + endif + + ! ------------------------------------------------- ! + ! Optional Accretion enhancement factor ! + ! ------------------------------------------------- ! + + accre_enhan(:ncol,:pver) = 1._r8 + + ! ------------------------------------------------- ! + ! Diagnose some output variables ! + ! ------------------------------------------------- ! + + ! density + rho(:ncol,1:pver) = state1%pmid(:ncol,1:pver)/(rair*state1%t(:ncol,1:pver)) + rho(:ncol,pverp) = state1%ps(:ncol)/(rair*state1%t(:ncol,pver)) + + eps = rair/rh2o + wpthvp(:,:) = 0.0_r8 + do k=1,pver + do i=1,ncol + ! buoyancy flux + wpthvp(i,k) = (wpthlp(i,k)-(apply_const*wpthlp_const))+((1._r8-eps)/eps)*theta0* & + (wprtp(i,k)-(apply_const*wprtp_const))+((latvap/cpair)* & + state1%exner(i,k)-(1._r8/eps)*theta0)*wprcp(i,k) + + ! total water mixing ratio + qt_output(i,k) = state1%q(i,k,ixq)+state1%q(i,k,ixcldliq)+state1%q(i,k,ixcldice) + ! liquid water potential temperature + thetal_output(i,k) = (state1%t(i,k)*state1%exner(i,k))-(latvap/cpair)*state1%q(i,k,ixcldliq) + ! liquid water static energy + sl_output(i,k) = cpair*state1%t(i,k)+gravit*state1%zm(i,k)-latvap*state1%q(i,k,ixcldliq) + enddo + enddo + + do k=1,pverp + do i=1,ncol + wpthlp_output(i,k) = (wpthlp(i,k)-(apply_const*wpthlp_const))*rho(i,k)*cpair ! liquid water potential temperature flux + wprtp_output(i,k) = (wprtp(i,k)-(apply_const*wprtp_const))*rho(i,k)*latvap ! total water mixig ratio flux + rtpthlp_output(i,k) = rtpthlp(i,k)-(apply_const*rtpthlp_const) ! rtpthlp output + wp3_output(i,k) = wp3(i,k) - (apply_const*wp3_const) ! wp3 output + tke(i,k) = 0.5_r8*(up2(i,k)+vp2(i,k)+wp2(i,k)) ! turbulent kinetic energy + enddo + enddo + + ! --------------------------------------------------------------------------------- ! + ! Diagnose some quantities that are computed in macrop_tend here. ! + ! These are inputs required for the microphysics calculation. ! + ! ! + ! FIRST PART COMPUTES THE STRATIFORM CLOUD FRACTION FROM CLUBB CLOUD FRACTION ! + ! --------------------------------------------------------------------------------- ! + + ! initialize variables + alst(:,:) = 0.0_r8 + qlst(:,:) = 0.0_r8 + + do k=1,pver + do i=1,ncol + alst(i,k) = cloud_frac(i,k) + qlst(i,k) = rcm(i,k)/max(0.01_r8,alst(i,k)) ! Incloud stratus condensate mixing ratio + enddo + enddo + + ! --------------------------------------------------------------------------------- ! + ! THIS PART COMPUTES CONVECTIVE AND DEEP CONVECTIVE CLOUD FRACTION ! + ! --------------------------------------------------------------------------------- ! + + deepcu(:,pver) = 0.0_r8 + shalcu(:,pver) = 0.0_r8 + + do k=1,pver-1 + do i=1,ncol + ! diagnose the deep convective cloud fraction, as done in macrophysics based on the + ! deep convective mass flux, read in from pbuf. Since shallow convection is never + ! called, the shallow convective mass flux will ALWAYS be zero, ensuring that this cloud + ! fraction is purely from deep convection scheme. + deepcu(i,k) = max(0.0_r8,min(0.1_r8*log(1.0_r8+500.0_r8*(cmfmc(i,k+1)-cmfmc_sh(i,k+1))),0.6_r8)) + shalcu(i,k) = 0._r8 + + if (deepcu(i,k) <= frac_limit .or. dp_icwmr(i,k) < ic_limit) then + deepcu(i,k) = 0._r8 + endif + + ! using the deep convective cloud fraction, and CLUBB cloud fraction (variable + ! "cloud_frac"), compute the convective cloud fraction. This follows the formulation + ! found in macrophysics code. Assumes that convective cloud is all nonstratiform cloud + ! from CLUBB plus the deep convective cloud fraction + concld(i,k) = min(cloud_frac(i,k)-alst(i,k)+deepcu(i,k),0.80_r8) + enddo + enddo + + if (single_column) then + if (trim(scm_clubb_iop_name) .eq. 'ATEX_48hr' .or. & + trim(scm_clubb_iop_name) .eq. 'BOMEX_5day' .or. & + trim(scm_clubb_iop_name) .eq. 'DYCOMSrf01_4day' .or. & + trim(scm_clubb_iop_name) .eq. 'DYCOMSrf02_06hr' .or. & + trim(scm_clubb_iop_name) .eq. 'RICO_3day' .or. & + trim(scm_clubb_iop_name) .eq. 'ARM_CC') then + + deepcu(:,:) = 0.0_r8 + concld(:,:) = 0.0_r8 + + endif + endif + + ! --------------------------------------------------------------------------------- ! + ! COMPUTE THE ICE CLOUD FRACTION PORTION ! + ! use the aist_vector function to compute the ice cloud fraction ! + ! --------------------------------------------------------------------------------- ! + + aist(:,:top_lev-1) = 0._r8 + qsatfac(:, :top_lev-1) = 0._r8 + + do k = top_lev, pver + + ! For Type II PSC and for thin cirrus, the clouds can be thin, but + ! extensive and they should start forming when the gridbox mean saturation + ! reaches 1.0. + ! + ! For now, use the tropopause diagnostic to determine where the Type II + ! PSC should be, but in the future wold like a better metric that can also + ! identify the level for thin cirrus. Include the tropopause level so that + ! the cold point tropopause will use the stratospheric values. + where (k <= troplev) + rhmini = rhminis_const + rhmaxi = rhmaxis_const + elsewhere + rhmini = rhmini_const + rhmaxi = rhmaxi_const + end where + + call aist_vector(state1%q(:,k,ixq),state1%t(:,k),state1%pmid(:,k),state1%q(:,k,ixcldice), & + state1%q(:,k,ixnumice),cam_in%landfrac(:),cam_in%snowhland(:),aist(:,k),ncol,& + qsatfac_out=qsatfac(:,k), rhmini_in=rhmini, rhmaxi_in=rhmaxi) + enddo + + ! --------------------------------------------------------------------------------- ! + ! THIS PART COMPUTES THE LIQUID STRATUS FRACTION ! + ! ! + ! For now leave the computation of ice stratus fraction from macrop_driver intact ! + ! because CLUBB does nothing with ice. Here I simply overwrite the liquid stratus ! + ! fraction that was coded in macrop_driver ! + ! --------------------------------------------------------------------------------- ! + + ! Recompute net stratus fraction using maximum over-lapping assumption, as done + ! in macrophysics code, using alst computed above and aist read in from physics buffer + + do k=1,pver + do i=1,ncol + + ast(i,k) = max(alst(i,k),aist(i,k)) + + qist(i,k) = state1%q(i,k,ixcldice)/max(0.01_r8,aist(i,k)) + enddo + enddo + + ! Probably need to add deepcu cloud fraction to the cloud fraction array, else would just + ! be outputting the shallow convective cloud fraction + + do k=1,pver + do i=1,ncol + cloud_frac(i,k) = min(ast(i,k)+deepcu(i,k),1.0_r8) + enddo + enddo + + ! --------------------------------------------------------------------------------- ! + ! DIAGNOSE THE PBL DEPTH ! + ! this is needed for aerosol code ! + ! --------------------------------------------------------------------------------- ! + + do i=1,ncol + do k=1,pver + th(i,k) = state1%t(i,k)*state1%exner(i,k) + thv(i,k) = th(i,k)*(1.0_r8+zvir*state1%q(i,k,ixq)) + enddo + enddo + + ! diagnose surface friction and obukhov length (inputs to diagnose PBL depth) + call calc_ustar( ncol, state1%t(1:ncol,pver), state1%pmid(1:ncol,pver), cam_in%wsx(1:ncol), cam_in%wsy(1:ncol), & + rrho(1:ncol), ustar2(1:ncol)) + ! use correct qflux from coupler + call calc_obklen( ncol, th(1:ncol,pver), thv(1:ncol,pver), cam_in%cflx(1:ncol,1), cam_in%shf(1:ncol), & + rrho(1:ncol), ustar2(1:ncol), kinheat(1:ncol), kinwat(1:ncol), kbfs(1:ncol), & + obklen(1:ncol)) + + dummy2(:) = 0._r8 + dummy3(:) = 0._r8 + + where (kbfs(:ncol) .eq. -0.0_r8) kbfs(:ncol) = 0.0_r8 + + ! Compute PBL depth according to Holtslag-Boville Scheme + call pblintd(ncol, thv, state1%zm, state1%u, state1%v, & + ustar2, obklen, kbfs, pblh, dummy2, & + state1%zi, cloud_frac(:,1:pver), 1._r8-cam_in%landfrac, dummy3) + + ! Output the PBL depth + call outfld('PBLH', pblh, pcols, lchnk) + call outfld('PBLHMX', pblh, pcols, lchnk) + call outfld('PBLHMN', pblh, pcols, lchnk) + + ! Assign the first pver levels of cloud_frac back to cld + cld(:,1:pver) = cloud_frac(:,1:pver) + + ! --------------------------------------------------------------------------------- ! + ! END CLOUD FRACTION DIAGNOSIS, begin to store variables back into buffer ! + ! --------------------------------------------------------------------------------- ! + + ! Output calls of variables goes here + call outfld( 'RELVAR', relvar, pcols, lchnk ) + call outfld( 'RHO_CLUBB', rho, pcols, lchnk ) + call outfld( 'WP2_CLUBB', wp2, pcols, lchnk ) + call outfld( 'UP2_CLUBB', up2, pcols, lchnk ) + call outfld( 'VP2_CLUBB', vp2, pcols, lchnk ) + call outfld( 'WP3_CLUBB', wp3_output, pcols, lchnk ) + call outfld( 'UPWP_CLUBB', upwp, pcols, lchnk ) + call outfld( 'VPWP_CLUBB', vpwp, pcols, lchnk ) + call outfld( 'WPTHLP_CLUBB', wpthlp_output, pcols, lchnk ) + call outfld( 'WPRTP_CLUBB', wprtp_output, pcols, lchnk ) + + temp2dp(:ncol,:) = rtp2(:ncol,:)*1000._r8 + call outfld( 'RTP2_CLUBB', temp2dp, pcols, lchnk ) + + call outfld( 'THLP2_CLUBB', thlp2, pcols, lchnk ) + + rtpthlp_output(:ncol,:) = rtpthlp_output(:ncol,:) * 1000._r8 + call outfld( 'RTPTHLP_CLUBB', rtpthlp_output, pcols, lchnk ) + + temp2dp(:ncol,:) = rcm(:ncol,:) * 1000._r8 + call outfld( 'RCM_CLUBB', temp2dp, pcols, lchnk ) + + temp2dp(:ncol,:) = wprcp(:ncol,:) * latvap + call outfld( 'WPRCP_CLUBB', temp2dp, pcols, lchnk ) + + temp2dp(:ncol,:) = rcm_in_layer(:ncol,:) * 1000._r8 + call outfld( 'RCMINLAYER_CLUBB', temp2dp, pcols, lchnk ) + + temp2dp(:ncol,:) = wpthvp(:ncol,:) * cpair + call outfld( 'WPTHVP_CLUBB', temp2dp, pcols, lchnk ) + + call outfld( 'CLOUDFRAC_CLUBB', alst, pcols, lchnk ) + call outfld( 'CLOUDCOVER_CLUBB', cloud_frac, pcols, lchnk ) + call outfld( 'ZT_CLUBB', zt_out, pcols, lchnk ) + call outfld( 'ZM_CLUBB', zi_out, pcols, lchnk ) + call outfld( 'UM_CLUBB', um, pcols, lchnk ) + call outfld( 'VM_CLUBB', vm, pcols, lchnk ) + call outfld( 'THETAL', thetal_output, pcols, lchnk ) + call outfld( 'QT', qt_output, pcols, lchnk ) + call outfld( 'SL', sl_output, pcols, lchnk ) + call outfld( 'CONCLD', concld, pcols, lchnk ) + call outfld( 'CLUBB_GRID_SIZE', grid_dx, pcols, lchnk ) + call outfld( 'QSATFAC', qsatfac, pcols, lchnk) + + ! Output CLUBB history here + if (l_stats) then + + do i=1,stats_zt%num_output_fields + + temp1 = trim(stats_zt%file%var(i)%name) + sub = temp1 + if (len(temp1) .gt. 16) sub = temp1(1:16) + + call outfld(trim(sub), out_zt(:,:,i), pcols, lchnk ) + enddo + + do i=1,stats_zm%num_output_fields + + temp1 = trim(stats_zm%file%var(i)%name) + sub = temp1 + if (len(temp1) .gt. 16) sub = temp1(1:16) + + call outfld(trim(sub),out_zm(:,:,i), pcols, lchnk) + enddo + + if (l_output_rad_files) then + do i=1,stats_rad_zt%num_output_fields + call outfld(trim(stats_rad_zt%file%var(i)%name), out_radzt(:,:,i), pcols, lchnk) + enddo + + do i=1,stats_rad_zm%num_output_fields + call outfld(trim(stats_rad_zm%file%var(i)%name), out_radzm(:,:,i), pcols, lchnk) + enddo + endif + + do i=1,stats_sfc%num_output_fields + call outfld(trim(stats_sfc%file%var(i)%name), out_sfc(:,:,i), pcols, lchnk) + enddo + + endif + + return +#endif + end subroutine clubb_tend_cam + + ! =============================================================================== ! + ! ! + ! =============================================================================== ! + +#ifdef CLUBB_SGS +! ---------------------------------------------------------------------- +! +! DISCLAIMER : this code appears to be correct but has not been +! very thouroughly tested. If you do notice any +! anomalous behaviour then please contact Andy and/or +! Bjorn +! +! Function diag_ustar: returns value of ustar using the below +! similarity functions and a specified buoyancy flux (bflx) given in +! kinematic units +! +! phi_m (zeta > 0) = (1 + am * zeta) +! phi_m (zeta < 0) = (1 - bm * zeta)^(-1/4) +! +! where zeta = z/lmo and lmo = (theta_rev/g*vonk) * (ustar^2/tstar) +! +! Ref: Businger, 1973, Turbulent Transfer in the Atmospheric Surface +! Layer, in Workshop on Micormeteorology, pages 67-100. +! +! Code writen March, 1999 by Bjorn Stevens +! + +real(r8) function diag_ustar( z, bflx, wnd, z0 ) + +use shr_const_mod, only : shr_const_karman, shr_const_pi, shr_const_g + +implicit none + +real(r8), parameter :: am = 4.8_r8 ! " " " +real(r8), parameter :: bm = 19.3_r8 ! " " " + +real(r8), parameter :: grav = shr_const_g +real(r8), parameter :: vonk = shr_const_karman +real(r8), parameter :: pi = shr_const_pi + +real(r8), intent (in) :: z ! height where u locates +real(r8), intent (in) :: bflx ! surface buoyancy flux (m^2/s^3) +real(r8), intent (in) :: wnd ! wind speed at z +real(r8), intent (in) :: z0 ! momentum roughness height + + +integer :: iterate +real(r8) :: lnz, klnz, c1, x, psi1, zeta, lmo, ustar + +lnz = log( z / z0 ) +klnz = vonk/lnz +c1 = pi / 2.0_r8 - 3.0_r8*log( 2.0_r8 ) + +ustar = wnd*klnz +if (abs(bflx) > 1.e-6_r8) then + do iterate=1,4 + + if (ustar > 1.e-6_r8) then + lmo = -ustar**3 / ( vonk * bflx ) + zeta = z/lmo + if (zeta > 0._r8) then + ustar = vonk*wnd /(lnz + am*zeta) + else + x = sqrt( sqrt( 1.0_r8 - bm*zeta ) ) + psi1 = 2._r8*log( 1.0_r8+x ) + log( 1.0_r8+x*x ) - 2._r8*atan( x ) + c1 + ustar = wnd*vonk/(lnz - psi1) + end if + + endif + + end do +end if + + +diag_ustar = ustar + +return + + +end function diag_ustar +#endif + + ! =============================================================================== ! + ! ! + ! =============================================================================== ! + +#ifdef CLUBB_SGS + + subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & + nnzp, nnrad_zt,nnrad_zm, delt ) + ! + ! Description: Initializes the statistics saving functionality of + ! the CLUBB model. This is for purpose of CAM-CLUBB interface. Here + ! the traditional stats_init of CLUBB is not called, as it is not compatible + ! with CAM output. + + !----------------------------------------------------------------------- + + + use stats_variables, only: & + stats_zt, & ! Variables + ztscr01, & + ztscr02, & + ztscr03, & + ztscr04, & + ztscr05, & + ztscr06, & + ztscr07, & + ztscr08, & + ztscr09, & + ztscr10, & + ztscr11, & + ztscr12, & + ztscr13, & + ztscr14, & + ztscr15, & + ztscr16, & + ztscr17, & + ztscr18, & + ztscr19, & + ztscr20, & + ztscr21 + + use stats_variables, only: & + stats_zm, & + zmscr01, & + zmscr02, & + zmscr03, & + zmscr04, & + zmscr05, & + zmscr06, & + zmscr07, & + zmscr08, & + zmscr09, & + zmscr10, & + zmscr11, & + zmscr12, & + zmscr13, & + zmscr14, & + zmscr15, & + zmscr16, & + zmscr17, & + stats_rad_zt, & + stats_rad_zm, & + stats_sfc, & + l_stats, & + l_output_rad_files, & + stats_tsamp, & + stats_tout, & + l_stats_samp, & + l_stats_last, & + l_netcdf, & + l_grads + + use clubb_precision, only: time_precision ! + use stats_zm_module, only: nvarmax_zm, stats_init_zm ! + use stats_zt_module, only: nvarmax_zt, stats_init_zt ! + use stats_rad_zt_module, only: nvarmax_rad_zt, stats_init_rad_zt ! + use stats_rad_zm_module, only: nvarmax_rad_zm, stats_init_rad_zm ! + use stats_sfc_module, only: nvarmax_sfc, stats_init_sfc ! + use constants_clubb, only: fstderr, var_length ! + use cam_history, only: addfld, horiz_only + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use cam_abortutils, only: endrun + use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_character + + implicit none + + ! Input Variables + + logical, intent(in) :: l_stats_in ! Stats on? T/F + + real(kind=time_precision), intent(in) :: & + stats_tsamp_in, & ! Sampling interval [s] + stats_tout_in ! Output interval [s] + + integer, intent(in) :: nnzp ! Grid points in the vertical [count] + integer, intent(in) :: nnrad_zt ! Grid points in the radiation grid [count] + integer, intent(in) :: nnrad_zm ! Grid points in the radiation grid [count] + + real(kind=time_precision), intent(in) :: delt ! Timestep (dtmain in CLUBB) [s] + + + ! Local Variables + + ! Namelist Variables + + character(len=*), parameter :: subr = 'stats_init_clubb' + + character(len=var_length), dimension(nvarmax_zt) :: clubb_vars_zt ! Variables on the thermodynamic levels + character(len=var_length), dimension(nvarmax_zm) :: clubb_vars_zm ! Variables on the momentum levels + character(len=var_length), dimension(nvarmax_rad_zt) :: clubb_vars_rad_zt ! Variables on the radiation levels + character(len=var_length), dimension(nvarmax_rad_zm) :: clubb_vars_rad_zm ! Variables on the radiation levels + character(len=var_length), dimension(nvarmax_sfc) :: clubb_vars_sfc ! Variables at the model surface + + namelist /clubb_stats_nl/ & + clubb_vars_zt, & + clubb_vars_zm, & + clubb_vars_rad_zt, & + clubb_vars_rad_zm, & + clubb_vars_sfc + + ! Local Variables + + logical :: l_error + + character(len=200) :: temp1, sub + + integer :: i, ntot, read_status + integer :: iunit, ierr + + ! Initialize + l_error = .false. + + ! Set stats_variables variables with inputs from calling subroutine + l_stats = l_stats_in + + stats_tsamp = stats_tsamp_in + stats_tout = stats_tout_in + + if ( .not. l_stats ) then + l_stats_samp = .false. + l_stats_last = .false. + return + end if + + ! Initialize namelist variables + + clubb_vars_zt = '' + clubb_vars_zm = '' + clubb_vars_rad_zt = '' + clubb_vars_rad_zm = '' + clubb_vars_sfc = '' + + ! Read variables to compute from the namelist + if (masterproc) then + iunit= getunit() + open(unit=iunit,file="atm_in",status='old') + call find_group_name(iunit, 'clubb_stats_nl', status=read_status) + if (read_status == 0) then + read(unit=iunit, nml=clubb_stats_nl, iostat=read_status) + if (read_status /= 0) then + call endrun('stats_init_clubb: error reading namelist') + end if + end if + close(unit=iunit) + call freeunit(iunit) + end if + + ! Broadcast namelist variables + call mpi_bcast(clubb_vars_zt, var_length*nvarmax_zt, mpi_character, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(subr//": FATAL: mpi_bcast: clubb_vars_zt") + call mpi_bcast(clubb_vars_zm, var_length*nvarmax_zm, mpi_character, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(subr//": FATAL: mpi_bcast: clubb_vars_zm") + call mpi_bcast(clubb_vars_rad_zt, var_length*nvarmax_rad_zt, mpi_character, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(subr//": FATAL: mpi_bcast: clubb_vars_rad_zt") + call mpi_bcast(clubb_vars_rad_zm, var_length*nvarmax_rad_zm, mpi_character, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(subr//": FATAL: mpi_bcast: clubb_vars_rad_zm") + call mpi_bcast(clubb_vars_sfc, var_length*nvarmax_sfc, mpi_character, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(subr//": FATAL: mpi_bcast: clubb_vars_sfc") + + ! Hardcode these for use in CAM-CLUBB, don't want either + l_netcdf = .false. + l_grads = .false. + + ! Check sampling and output frequencies + + ! The model time step length, delt (which is dtmain), should multiply + ! evenly into the statistical sampling time step length, stats_tsamp. + if ( abs( stats_tsamp/delt - floor(stats_tsamp/delt) ) > 1.e-8_r8 ) then + l_error = .true. ! This will cause the run to stop. + write(fstderr,*) 'Error: stats_tsamp should be an even multiple of ', & + 'delt (which is dtmain). Check the appropriate ', & + 'model.in file.' + write(fstderr,*) 'stats_tsamp = ', stats_tsamp + write(fstderr,*) 'delt = ', delt + endif + + ! Initialize zt (mass points) + + i = 1 + do while ( ichar(clubb_vars_zt(i)(1:1)) /= 0 .and. & + len_trim(clubb_vars_zt(i)) /= 0 .and. & + i <= nvarmax_zt ) + i = i + 1 + enddo + ntot = i - 1 + if ( ntot == nvarmax_zt ) then + write(fstderr,*) "There are more statistical variables listed in ", & + "clubb_vars_zt than allowed for by nvarmax_zt." + write(fstderr,*) "Check the number of variables listed for clubb_vars_zt ", & + "in the stats namelist, or change nvarmax_zt." + write(fstderr,*) "nvarmax_zt = ", nvarmax_zt + call endrun ("stats_init_clubb: number of zt statistical variables exceeds limit") + endif + + stats_zt%num_output_fields = ntot + stats_zt%kk = nnzp + + allocate( stats_zt%z( stats_zt%kk ) ) + + allocate( stats_zt%accum_field_values( 1, 1, stats_zt%kk, stats_zt%num_output_fields ) ) + allocate( stats_zt%accum_num_samples( 1, 1, stats_zt%kk, stats_zt%num_output_fields ) ) + allocate( stats_zt%l_in_update( 1, 1, stats_zt%kk, stats_zt%num_output_fields ) ) + call stats_zero( stats_zt%kk, stats_zt%num_output_fields, stats_zt%accum_field_values, & + stats_zt%accum_num_samples, stats_zt%l_in_update ) + + allocate( stats_zt%file%var( stats_zt%num_output_fields ) ) + allocate( stats_zt%file%z( stats_zt%kk ) ) + + ! Allocate scratch space + + allocate( ztscr01(stats_zt%kk) ) + allocate( ztscr02(stats_zt%kk) ) + allocate( ztscr03(stats_zt%kk) ) + allocate( ztscr04(stats_zt%kk) ) + allocate( ztscr05(stats_zt%kk) ) + allocate( ztscr06(stats_zt%kk) ) + allocate( ztscr07(stats_zt%kk) ) + allocate( ztscr08(stats_zt%kk) ) + allocate( ztscr09(stats_zt%kk) ) + allocate( ztscr10(stats_zt%kk) ) + allocate( ztscr11(stats_zt%kk) ) + allocate( ztscr12(stats_zt%kk) ) + allocate( ztscr13(stats_zt%kk) ) + allocate( ztscr14(stats_zt%kk) ) + allocate( ztscr15(stats_zt%kk) ) + allocate( ztscr16(stats_zt%kk) ) + allocate( ztscr17(stats_zt%kk) ) + allocate( ztscr18(stats_zt%kk) ) + allocate( ztscr19(stats_zt%kk) ) + allocate( ztscr20(stats_zt%kk) ) + allocate( ztscr21(stats_zt%kk) ) + + ztscr01 = 0.0_r8 + ztscr02 = 0.0_r8 + ztscr03 = 0.0_r8 + ztscr04 = 0.0_r8 + ztscr05 = 0.0_r8 + ztscr06 = 0.0_r8 + ztscr07 = 0.0_r8 + ztscr08 = 0.0_r8 + ztscr09 = 0.0_r8 + ztscr10 = 0.0_r8 + ztscr11 = 0.0_r8 + ztscr12 = 0.0_r8 + ztscr13 = 0.0_r8 + ztscr14 = 0.0_r8 + ztscr15 = 0.0_r8 + ztscr16 = 0.0_r8 + ztscr17 = 0.0_r8 + ztscr18 = 0.0_r8 + ztscr19 = 0.0_r8 + ztscr20 = 0.0_r8 + ztscr21 = 0.0_r8 + + ! Default initialization for array indices for zt + + call stats_init_zt( clubb_vars_zt, l_error ) + + ! Initialize zm (momentum points) + + i = 1 + do while ( ichar(clubb_vars_zm(i)(1:1)) /= 0 .and. & + len_trim(clubb_vars_zm(i)) /= 0 .and. & + i <= nvarmax_zm ) + i = i + 1 + end do + ntot = i - 1 + if ( ntot == nvarmax_zm ) then + write(fstderr,*) "There are more statistical variables listed in ", & + "clubb_vars_zm than allowed for by nvarmax_zm." + write(fstderr,*) "Check the number of variables listed for clubb_vars_zm ", & + "in the stats namelist, or change nvarmax_zm." + write(fstderr,*) "nvarmax_zm = ", nvarmax_zm + call endrun ("stats_init_clubb: number of zm statistical variables exceeds limit") + endif + + stats_zm%num_output_fields = ntot + stats_zm%kk = nnzp + + allocate( stats_zm%z( stats_zm%kk ) ) + + allocate( stats_zm%accum_field_values( 1, 1, stats_zm%kk, stats_zm%num_output_fields ) ) + allocate( stats_zm%accum_num_samples( 1, 1, stats_zm%kk, stats_zm%num_output_fields ) ) + allocate( stats_zm%l_in_update( 1, 1, stats_zm%kk, stats_zm%num_output_fields ) ) + call stats_zero( stats_zm%kk, stats_zm%num_output_fields, stats_zm%accum_field_values, & + stats_zm%accum_num_samples, stats_zm%l_in_update ) + + allocate( stats_zm%file%var( stats_zm%num_output_fields ) ) + allocate( stats_zm%file%z( stats_zm%kk ) ) + + ! Allocate scratch space + + allocate( zmscr01(stats_zm%kk) ) + allocate( zmscr02(stats_zm%kk) ) + allocate( zmscr03(stats_zm%kk) ) + allocate( zmscr04(stats_zm%kk) ) + allocate( zmscr05(stats_zm%kk) ) + allocate( zmscr06(stats_zm%kk) ) + allocate( zmscr07(stats_zm%kk) ) + allocate( zmscr08(stats_zm%kk) ) + allocate( zmscr09(stats_zm%kk) ) + allocate( zmscr10(stats_zm%kk) ) + allocate( zmscr11(stats_zm%kk) ) + allocate( zmscr12(stats_zm%kk) ) + allocate( zmscr13(stats_zm%kk) ) + allocate( zmscr14(stats_zm%kk) ) + allocate( zmscr15(stats_zm%kk) ) + allocate( zmscr16(stats_zm%kk) ) + allocate( zmscr17(stats_zm%kk) ) + + zmscr01 = 0.0_r8 + zmscr02 = 0.0_r8 + zmscr03 = 0.0_r8 + zmscr04 = 0.0_r8 + zmscr05 = 0.0_r8 + zmscr06 = 0.0_r8 + zmscr07 = 0.0_r8 + zmscr08 = 0.0_r8 + zmscr09 = 0.0_r8 + zmscr10 = 0.0_r8 + zmscr11 = 0.0_r8 + zmscr12 = 0.0_r8 + zmscr13 = 0.0_r8 + zmscr14 = 0.0_r8 + zmscr15 = 0.0_r8 + zmscr16 = 0.0_r8 + zmscr17 = 0.0_r8 + + call stats_init_zm( clubb_vars_zm, l_error ) + + ! Initialize rad_zt (radiation points) + + if (l_output_rad_files) then + + i = 1 + do while ( ichar(clubb_vars_rad_zt(i)(1:1)) /= 0 .and. & + len_trim(clubb_vars_rad_zt(i)) /= 0 .and. & + i <= nvarmax_rad_zt ) + i = i + 1 + end do + ntot = i - 1 + if ( ntot == nvarmax_rad_zt ) then + write(fstderr,*) "There are more statistical variables listed in ", & + "clubb_vars_rad_zt than allowed for by nvarmax_rad_zt." + write(fstderr,*) "Check the number of variables listed for clubb_vars_rad_zt ", & + "in the stats namelist, or change nvarmax_rad_zt." + write(fstderr,*) "nvarmax_rad_zt = ", nvarmax_rad_zt + call endrun ("stats_init_clubb: number of rad_zt statistical variables exceeds limit") + endif + + stats_rad_zt%num_output_fields = ntot + stats_rad_zt%kk = nnrad_zt + + allocate( stats_rad_zt%z( stats_rad_zt%kk ) ) + + allocate( stats_rad_zt%accum_field_values( 1, 1, stats_rad_zt%kk, stats_rad_zt%num_output_fields ) ) + allocate( stats_rad_zt%accum_num_samples( 1, 1, stats_rad_zt%kk, stats_rad_zt%num_output_fields ) ) + allocate( stats_rad_zt%l_in_update( 1, 1, stats_rad_zt%kk, stats_rad_zt%num_output_fields ) ) + + call stats_zero( stats_rad_zt%kk, stats_rad_zt%num_output_fields, stats_rad_zt%accum_field_values, & + stats_rad_zt%accum_num_samples, stats_rad_zt%l_in_update ) + + allocate( stats_rad_zt%file%var( stats_rad_zt%num_output_fields ) ) + allocate( stats_rad_zt%file%z( stats_rad_zt%kk ) ) + + call stats_init_rad_zt( clubb_vars_rad_zt, l_error ) + + ! Initialize rad_zm (radiation points) + + i = 1 + do while ( ichar(clubb_vars_rad_zm(i)(1:1)) /= 0 .and. & + len_trim(clubb_vars_rad_zm(i)) /= 0 .and. & + i <= nvarmax_rad_zm ) + i = i + 1 + end do + ntot = i - 1 + if ( ntot == nvarmax_rad_zm ) then + write(fstderr,*) "There are more statistical variables listed in ", & + "clubb_vars_rad_zm than allowed for by nvarmax_rad_zm." + write(fstderr,*) "Check the number of variables listed for clubb_vars_rad_zm ", & + "in the stats namelist, or change nvarmax_rad_zm." + write(fstderr,*) "nvarmax_rad_zm = ", nvarmax_rad_zm + call endrun ("stats_init_clubb: number of rad_zm statistical variables exceeds limit") + endif + + stats_rad_zm%num_output_fields = ntot + stats_rad_zm%kk = nnrad_zm + + allocate( stats_rad_zm%z( stats_rad_zm%kk ) ) + + allocate( stats_rad_zm%accum_field_values( 1, 1, stats_rad_zm%kk, stats_rad_zm%num_output_fields ) ) + allocate( stats_rad_zm%accum_num_samples( 1, 1, stats_rad_zm%kk, stats_rad_zm%num_output_fields ) ) + allocate( stats_rad_zm%l_in_update( 1, 1, stats_rad_zm%kk, stats_rad_zm%num_output_fields ) ) + + call stats_zero( stats_rad_zm%kk, stats_rad_zm%num_output_fields, stats_rad_zm%accum_field_values, & + stats_rad_zm%accum_num_samples, stats_rad_zm%l_in_update ) + + allocate( stats_rad_zm%file%var( stats_rad_zm%num_output_fields ) ) + allocate( stats_rad_zm%file%z( stats_rad_zm%kk ) ) + + call stats_init_rad_zm( clubb_vars_rad_zm, l_error ) + end if ! l_output_rad_files + + + ! Initialize sfc (surface point) + + i = 1 + do while ( ichar(clubb_vars_sfc(i)(1:1)) /= 0 .and. & + len_trim(clubb_vars_sfc(i)) /= 0 .and. & + i <= nvarmax_sfc ) + i = i + 1 + end do + ntot = i - 1 + if ( ntot == nvarmax_sfc ) then + write(fstderr,*) "There are more statistical variables listed in ", & + "clubb_vars_sfc than allowed for by nvarmax_sfc." + write(fstderr,*) "Check the number of variables listed for clubb_vars_sfc ", & + "in the stats namelist, or change nvarmax_sfc." + write(fstderr,*) "nvarmax_sfc = ", nvarmax_sfc + call endrun ("stats_init_clubb: number of sfc statistical variables exceeds limit") + endif + + stats_sfc%num_output_fields = ntot + stats_sfc%kk = 1 + + allocate( stats_sfc%z( stats_sfc%kk ) ) + + allocate( stats_sfc%accum_field_values( 1, 1, stats_sfc%kk, stats_sfc%num_output_fields ) ) + allocate( stats_sfc%accum_num_samples( 1, 1, stats_sfc%kk, stats_sfc%num_output_fields ) ) + allocate( stats_sfc%l_in_update( 1, 1, stats_sfc%kk, stats_sfc%num_output_fields ) ) + + call stats_zero( stats_sfc%kk, stats_sfc%num_output_fields, stats_sfc%accum_field_values, & + stats_sfc%accum_num_samples, stats_sfc%l_in_update ) + + allocate( stats_sfc%file%var( stats_sfc%num_output_fields ) ) + allocate( stats_sfc%file%z( stats_sfc%kk ) ) + + call stats_init_sfc( clubb_vars_sfc, l_error ) + + ! Check for errors + + if ( l_error ) then + call endrun ('stats_init: errors found') + endif + +! Now call add fields + do i = 1, stats_zt%num_output_fields + + temp1 = trim(stats_zt%file%var(i)%name) + sub = temp1 + if (len(temp1) .gt. 16) sub = temp1(1:16) + +!!XXgoldyXX: Probably need a hist coord for nnzp for the vertical + call addfld(trim(sub),(/ 'ilev' /),& + 'A',trim(stats_zt%file%var(i)%units),trim(stats_zt%file%var(i)%description)) + enddo + + do i = 1, stats_zm%num_output_fields + + temp1 = trim(stats_zm%file%var(i)%name) + sub = temp1 + if (len(temp1) .gt. 16) sub = temp1(1:16) + +!!XXgoldyXX: Probably need a hist coord for nnzp for the vertical + call addfld(trim(sub),(/ 'ilev' /),& + 'A',trim(stats_zm%file%var(i)%units),trim(stats_zm%file%var(i)%description)) + enddo + + if (l_output_rad_files) then +!!XXgoldyXX: Probably need a hist coord for nnzp for the vertical + do i = 1, stats_rad_zt%num_output_fields + call addfld(trim(stats_rad_zt%file%var(i)%name),(/ 'ilev' /),& + 'A',trim(stats_rad_zt%file%var(i)%units),trim(stats_rad_zt%file%var(i)%description)) + enddo + + do i = 1, stats_rad_zm%num_output_fields + call addfld(trim(stats_rad_zm%file%var(i)%name),(/ 'ilev' /),& + 'A',trim(stats_rad_zm%file%var(i)%units),trim(stats_rad_zm%file%var(i)%description)) + enddo + endif + + do i = 1, stats_sfc%num_output_fields + call addfld(trim(stats_sfc%file%var(i)%name),horiz_only,& + 'A',trim(stats_sfc%file%var(i)%units),trim(stats_sfc%file%var(i)%description)) + enddo + + return + + + end subroutine stats_init_clubb + +#endif + + ! =============================================================================== ! + ! ! + ! =============================================================================== ! + + + !----------------------------------------------------------------------- + subroutine stats_end_timestep_clubb(thecol,out_zt,out_zm,out_radzt,out_radzm,out_sfc) + + ! Description: Called when the stats timestep has ended. This subroutine + ! is responsible for calling statistics to be written to the output + ! format. + !----------------------------------------------------------------------- + +#ifdef CLUBB_SGS + + use shr_infnan_mod, only: is_nan => shr_infnan_isnan + + use constants_clubb, only: & + fstderr ! Constant(s) + + use stats_variables, only: & + stats_zt, & ! Variable(s) + stats_zm, & + stats_rad_zt, & + stats_rad_zm, & + stats_sfc, & + l_stats_last, & + stats_tsamp, & + stats_tout, & + l_output_rad_files + + use error_code, only: & + clubb_at_least_debug_level ! Procedure(s) + + use cam_abortutils, only: endrun + + implicit none + + +#endif + + integer :: thecol + + real(r8), intent(inout) :: out_zt(:,:,:) ! (pcols,pverp,zt%nn) + real(r8), intent(inout) :: out_zm(:,:,:) ! (pcols,pverp,zt%nn) + real(r8), intent(inout) :: out_radzt(:,:,:) ! (pcols,pverp,rad_zt%nn) + real(r8), intent(inout) :: out_radzm(:,:,:) ! (pcols,pverp,rad_zm%nn) + real(r8), intent(inout) :: out_sfc(:,:,:) ! (pcols,1,sfc%nn) + +#ifdef CLUBB_SGS + ! Local Variables + + integer :: i, k + logical :: l_error + + ! Check if it is time to write to file + + if ( .not. l_stats_last ) return + + ! Initialize + l_error = .false. + + ! Look for errors by checking the number of sampling points + ! for each variable in the zt statistics at each vertical level. + do i = 1, stats_zt%num_output_fields + do k = 1, stats_zt%kk + + if ( stats_zt%accum_num_samples(1,1,k,i) /= 0 .and. & + stats_zt%accum_num_samples(1,1,k,i) /= floor(stats_tout/stats_tsamp) ) then + + l_error = .true. ! This will stop the run + + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,*) 'Possible sampling error for variable ', & + trim(stats_zt%file%var(i)%name), ' in zt ', & + 'at k = ', k, & + '; stats_zt%accum_num_samples(',k,',',i,') = ', stats_zt%accum_num_samples(1,1,k,i) + endif + + endif + + enddo + enddo + + ! Look for errors by checking the number of sampling points + ! for each variable in the zm statistics at each vertical level. + do i = 1, stats_zm%num_output_fields + do k = 1, stats_zm%kk + + if ( stats_zm%accum_num_samples(1,1,k,i) /= 0 .and. & + stats_zm%accum_num_samples(1,1,k,i) /= floor(stats_tout/stats_tsamp) ) then + + l_error = .true. ! This will stop the run + + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,*) 'Possible sampling error for variable ', & + trim(stats_zm%file%var(i)%name), ' in zm ', & + 'at k = ', k, & + '; stats_zm%accum_num_samples(',k,',',i,') = ', stats_zm%accum_num_samples(1,1,k,i) + endif + + endif + + enddo + enddo + + if (l_output_rad_files) then + ! Look for errors by checking the number of sampling points + ! for each variable in the rad_zt statistics at each vertical level. + do i = 1, stats_rad_zt%num_output_fields + do k = 1, stats_rad_zt%kk + + if ( stats_rad_zt%accum_num_samples(1,1,k,i) /= 0 .and. & + stats_rad_zt%accum_num_samples(1,1,k,i) /= floor(stats_tout/stats_tsamp) ) then + + l_error = .true. ! This will stop the run + + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,*) 'Possible sampling error for variable ', & + trim(stats_rad_zt%file%var(i)%name), ' in rad_zt ', & + 'at k = ', k, & + '; stats_rad_zt%accum_num_samples(',k,',',i,') = ', stats_rad_zt%accum_num_samples(1,1,k,i) + endif + + endif + + enddo + enddo + + ! Look for errors by checking the number of sampling points + ! for each variable in the rad_zm statistics at each vertical level. + do i = 1, stats_rad_zm%num_output_fields + do k = 1, stats_rad_zm%kk + + if ( stats_rad_zm%accum_num_samples(1,1,k,i) /= 0 .and. & + stats_rad_zm%accum_num_samples(1,1,k,i) /= floor(stats_tout/stats_tsamp) ) then + + l_error = .true. ! This will stop the run + + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,*) 'Possible sampling error for variable ', & + trim(stats_rad_zm%file%var(i)%name), ' in rad_zm ', & + 'at k = ', k, & + '; stats_rad_zm%accum_num_samples(',k,',',i,') = ', stats_rad_zm%accum_num_samples(1,1,k,i) + endif + + endif + + enddo + enddo + end if ! l_output_rad_files + + ! Look for errors by checking the number of sampling points + ! for each variable in the sfc statistics at each vertical level. + do i = 1, stats_sfc%num_output_fields + do k = 1, stats_sfc%kk + + if ( stats_sfc%accum_num_samples(1,1,k,i) /= 0 .and. & + stats_sfc%accum_num_samples(1,1,k,i) /= floor(stats_tout/stats_tsamp) ) then + + l_error = .true. ! This will stop the run + + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,*) 'Possible sampling error for variable ', & + trim(stats_sfc%file%var(i)%name), ' in sfc ', & + 'at k = ', k, & + '; stats_sfc%accum_num_samples(',k,',',i,') = ', stats_sfc%accum_num_samples(1,1,k,i) + endif + + endif + + enddo + enddo + + ! Stop the run if errors are found. + if ( l_error ) then + write(fstderr,*) 'Possible statistical sampling error' + write(fstderr,*) 'For details, set debug_level to a value of at ', & + 'least 1 in the appropriate model.in file.' + call endrun ('stats_end_timestep: error(s) found') + endif + + ! Compute averages + call stats_avg( stats_zt%kk, stats_zt%num_output_fields, stats_zt%accum_field_values, stats_zt%accum_num_samples ) + call stats_avg( stats_zm%kk, stats_zm%num_output_fields, stats_zm%accum_field_values, stats_zm%accum_num_samples ) + if (l_output_rad_files) then + call stats_avg( stats_rad_zt%kk, stats_rad_zt%num_output_fields, stats_rad_zt%accum_field_values, & + stats_rad_zt%accum_num_samples ) + call stats_avg( stats_rad_zm%kk, stats_rad_zm%num_output_fields, stats_rad_zm%accum_field_values, & + stats_rad_zm%accum_num_samples ) + end if + call stats_avg( stats_sfc%kk, stats_sfc%num_output_fields, stats_sfc%accum_field_values, stats_sfc%accum_num_samples ) + + ! Here we are not outputting the data, rather reading the stats into + ! arrays which are conformable to CAM output. Also, the data is "flipped" + ! in the vertical level to be the same as CAM output. + do i = 1, stats_zt%num_output_fields + do k = 1, stats_zt%kk + out_zt(thecol,pverp-k+1,i) = stats_zt%accum_field_values(1,1,k,i) + if(is_nan(out_zt(thecol,k,i))) out_zt(thecol,k,i) = 0.0_r8 + enddo + enddo + + do i = 1, stats_zm%num_output_fields + do k = 1, stats_zt%kk + out_zm(thecol,pverp-k+1,i) = stats_zm%accum_field_values(1,1,k,i) + if(is_nan(out_zm(thecol,k,i))) out_zm(thecol,k,i) = 0.0_r8 + enddo + enddo + + if (l_output_rad_files) then + do i = 1, stats_rad_zt%num_output_fields + do k = 1, stats_rad_zt%kk + out_radzt(thecol,pverp-k+1,i) = stats_rad_zt%accum_field_values(1,1,k,i) + if(is_nan(out_radzt(thecol,k,i))) out_radzt(thecol,k,i) = 0.0_r8 + enddo + enddo + + do i = 1, stats_rad_zm%num_output_fields + do k = 1, stats_rad_zm%kk + out_radzm(thecol,pverp-k+1,i) = stats_rad_zm%accum_field_values(1,1,k,i) + if(is_nan(out_radzm(thecol,k,i))) out_radzm(thecol,k,i) = 0.0_r8 + enddo + enddo + + ! Fill in values above the CLUBB top. + out_zt(thecol,:top_lev-1,:) = 0.0_r8 + out_zm(thecol,:top_lev-1,:) = 0.0_r8 + out_radzt(thecol,:top_lev-1,:) = 0.0_r8 + out_radzm(thecol,:top_lev-1,:) = 0.0_r8 + + endif + + do i = 1, stats_sfc%num_output_fields + out_sfc(thecol,1,i) = stats_sfc%accum_field_values(1,1,1,i) + if(is_nan(out_sfc(thecol,1,i))) out_sfc(thecol,1,i) = 0.0_r8 + enddo + + ! Reset sample fields + call stats_zero( stats_zt%kk, stats_zt%num_output_fields, stats_zt%accum_field_values, & + stats_zt%accum_num_samples, stats_zt%l_in_update ) + call stats_zero( stats_zm%kk, stats_zm%num_output_fields, stats_zm%accum_field_values, & + stats_zm%accum_num_samples, stats_zm%l_in_update ) + if (l_output_rad_files) then + call stats_zero( stats_rad_zt%kk, stats_rad_zt%num_output_fields, stats_rad_zt%accum_field_values, & + stats_rad_zt%accum_num_samples, stats_rad_zt%l_in_update ) + call stats_zero( stats_rad_zm%kk, stats_rad_zm%num_output_fields, stats_rad_zm%accum_field_values, & + stats_rad_zm%accum_num_samples, stats_rad_zm%l_in_update ) + end if + call stats_zero( stats_sfc%kk, stats_sfc%num_output_fields, stats_sfc%accum_field_values, & + stats_sfc%accum_num_samples, stats_sfc%l_in_update ) + + return + +#endif + + end subroutine stats_end_timestep_clubb + + + ! =============================================================================== ! + ! ! + ! =============================================================================== ! + +#ifdef CLUBB_SGS + + !----------------------------------------------------------------------- + subroutine stats_zero( kk, nn, x, n, l_in_update ) + + ! Description: + ! Initialize stats to zero + !----------------------------------------------------------------------- + + use clubb_precision, only: & + stat_rknd, & ! Variable(s) + stat_nknd + + + implicit none + + ! Input + integer, intent(in) :: kk, nn + + ! Output + real(kind=stat_rknd), dimension(1,1,kk,nn), intent(out) :: x + integer(kind=stat_nknd), dimension(1,1,kk,nn), intent(out) :: n + logical, dimension(1,1,kk,nn), intent(out) :: l_in_update + + ! Zero out arrays + + if ( nn > 0 ) then + x(:,:,:,:) = 0.0_r8 + n(:,:,:,:) = 0 + l_in_update(:,:,:,:) = .false. + end if + + return + + end subroutine stats_zero + +#endif + + ! =============================================================================== ! + ! ! + ! =============================================================================== ! + + +#ifdef CLUBB_SGS + !----------------------------------------------------------------------- + subroutine stats_avg( kk, nn, x, n ) + + ! Description: + ! Compute the average of stats fields + !----------------------------------------------------------------------- + use clubb_precision, only: & + stat_rknd, & ! Variable(s) + stat_nknd + + implicit none + + ! Input + integer, intent(in) :: nn, kk + integer(kind=stat_nknd), dimension(1,1,kk,nn), intent(in) :: n + + ! Output + real(kind=stat_rknd), dimension(1,1,kk,nn), intent(inout) :: x + + ! Internal + + integer k,m + + ! Compute averages + + do m=1,nn + do k=1,kk + + if ( n(1,1,k,m) > 0 ) then + x(1,1,k,m) = x(1,1,k,m) / real( n(1,1,k,m) ) + end if + + end do + end do + + return + + end subroutine stats_avg + + subroutine grid_size(state, grid_dx, grid_dy) + ! Determine the size of the grid for each of the columns in state + + use phys_grid, only: get_area_p + use shr_const_mod, only: shr_const_pi + use physics_types, only: physics_state + + + type(physics_state), intent(in) :: state + real(r8), intent(out) :: grid_dx(pcols), grid_dy(pcols) ! CAM grid [m] + + real(r8), parameter :: earth_ellipsoid1 = 111132.92_r8 ! first coefficient, meters per degree longitude at equator + real(r8), parameter :: earth_ellipsoid2 = 559.82_r8 ! second expansion coefficient for WGS84 ellipsoid + real(r8), parameter :: earth_ellipsoid3 = 1.175_r8 ! third expansion coefficient for WGS84 ellipsoid + + real(r8) :: mpdeglat, column_area, degree + integer :: i + + ! determine the column area in radians + do i=1,state%ncol + column_area = get_area_p(state%lchnk,i) + degree = sqrt(column_area)*(180._r8/shr_const_pi) + + ! Now find meters per degree latitude + ! Below equation finds distance between two points on an ellipsoid, derived from expansion + ! taking into account ellipsoid using World Geodetic System (WGS84) reference + mpdeglat = earth_ellipsoid1 - earth_ellipsoid2 * cos(2._r8*state%lat(i)) + earth_ellipsoid3 * cos(4._r8*state%lat(i)) + grid_dx(i) = mpdeglat * degree + grid_dy(i) = grid_dx(i) ! Assume these are the same + enddo + + end subroutine grid_size + +#endif + +end module clubb_intr diff --git a/src/NorESM/micro_mg2_0.F90 b/src/NorESM/micro_mg2_0.F90 index 823058308e..c2b8291e67 100644 --- a/src/NorESM/micro_mg2_0.F90 +++ b/src/NorESM/micro_mg2_0.F90 @@ -133,6 +133,9 @@ module micro_mg2_0 mi0, & rising_factorial +!RaFSIP GS/PG +use module_random_forests + implicit none private save @@ -189,7 +192,7 @@ module micro_mg2_0 real(r8) :: r ! dry air gas constant real(r8) :: rv ! water vapor gas constant real(r8) :: cpp ! specific heat of dry air -real(r8) :: tmelt ! freezing point of water (K) +real(r8) :: tmelt ! freezing point of water (k) ! latent heats of: real(r8) :: xxlv ! vaporization @@ -257,7 +260,7 @@ subroutine micro_mg_init( & real(r8), intent(in) :: rair real(r8), intent(in) :: rh2o real(r8), intent(in) :: cpair - real(r8), intent(in) :: tmelt_in ! Freezing point of water (K) + real(r8), intent(in) :: tmelt_in ! Freezing point of water (k) real(r8), intent(in) :: latvap real(r8), intent(in) :: latice real(r8), intent(in) :: rhmini_in ! Minimum rh for ice cloud fraction > 0. @@ -346,6 +349,36 @@ subroutine micro_mg_init( & xxlv_squared=xxlv**2 xxls_squared=xxls**2 +!----------------------------------------------------------------------------------- +! RaFSIP: INITIALIZE THE RANDOM FOREST PARAMETERS CALLING THE SUBROUTINES THAT +!ARE DEFINED IN THE MODULE_RANDOM_FOREST.F FILE !GS/PG +!---------------------------------------------------------------------------------- + + IF (FIRST_RAFSIP) THEN + + + CALL forestbrhm(jbt,max_nodes1,leftchild1,rightchild1,splitfeat1, & + nrnodes1,thresh1,out11,out12,out13) + + CALL forestbr(jbt,max_nodes2,leftchild2,rightchild2,splitfeat2, & + nrnodes2,thresh2,out21) + + CALL forestall(jbt,max_nodes3,leftchild3,rightchild3,splitfeat3, & + nrnodes3,thresh3,out31,out32,out33,out34,out35) + + CALL forestbrds(jbt,max_nodes4,leftchild4,rightchild4,splitfeat4, & + nrnodes4,thresh4,out41,out42,out43) + + CALL forestbrwarm(jbt,max_nodes5,leftchild5,rightchild5,splitfeat5, & + nrnodes5,thresh5,out51) + + + FIRST_RAFSIP = .FALSE. + + + ENDIF + + end subroutine micro_mg_init !=============================================================================== @@ -451,6 +484,8 @@ subroutine micro_mg_tend ( & evaporate_sublimate_precip, & bergeron_process_snow + ! RaFSIP parameterization GS/PG + !Authors: Hugh Morrison, Andrew Gettelman, NCAR, Peter Caldwell, LLNL ! e-mail: morrison@ucar.edu, andrew@ucar.edu @@ -458,7 +493,7 @@ subroutine micro_mg_tend ( & integer, intent(in) :: mgncol ! number of microphysics columns integer, intent(in) :: nlev ! number of layers real(r8), intent(in) :: deltatin ! time step (s) - real(r8), intent(in) :: t(mgncol,nlev) ! input temperature (K) + real(r8), intent(in) :: t(mgncol,nlev) ! input temperature (k) real(r8), intent(in) :: q(mgncol,nlev) ! input h20 vapor mixing ratio (kg/kg) ! note: all input cloud variables are grid-averaged @@ -799,8 +834,27 @@ subroutine micro_mg_tend ( & real(r8) :: qvi(mgncol,nlev) ! ice real(r8) :: qvn ! checking for RH after rain evap + ! RaFSIP additional parameters ! GS/PG + logical :: rafsip_on + !Inputs to SIP parameterization + real(r8) :: IWC(mgncol,nlev) ! TOTAL ICE WATER CONTENT IN KG/KG INPUT TO RaFSIP + real(r8) :: RIMC(mgncol,nlev) ! TOTAL CLOUD DROPLET RIMING IN KG/KG/S INPUT TO RaFSIP + real(r8) :: RIMR(mgncol,nlev) ! TOTAL RAINDROP RIMING IN KG/KG/S INPUT TO RaFSIP + real(r8) :: TEMPK(mgncol,nlev) ! TEMPERATURE IN K INPUT TO RaFSIP + real(r8) :: RHI(mgncol,nlev) ! RELATIVE HUMIDITY WRT ICE INPUT TO RaFSIP + real(r8) :: LWC(mgncol,nlev) ! TOTAL LIQUID WATER CONTENT IN KG/KG INPUT TO RaFSIP + !Outputs + real(r8) :: BR_RATE(mgncol,nlev) ! SIP RATE DUE TO COLLISIONAL BREAK-UP + real(r8) :: DS_RATE(mgncol,nlev) ! SIP RATE DUE TO DROPLET-SHATTERING + real(r8) :: HM_RATE(mgncol,nlev) ! SIP RATE DUE TO HALLETT-MOSSOP + real(r8) :: SIP_RATE(mgncol,nlev) ! TOTAL SIP rate predicted by the RaFSIP (kg-1 s-1) + real(r8) :: QIRSIP(mgncol,nlev) ! MASS TRASFERRED FROM RAINDROPS TO CLOUD ICE DUE TO HM OR DS + real(r8) :: QICSIP(mgncol,nlev) ! MASS TRASFERRED FROM CLOUD DROPLETS TO CLOUD ICE DUE TO THE DS + + ! relative humidity real(r8) :: relhum(mgncol,nlev) + real(r8) :: relhumi(mgncol,nlev) ! parameters for cloud water and cloud ice sedimentation calculations real(r8) :: fc(mgncol,nlev) @@ -875,6 +929,19 @@ subroutine micro_mg_tend ( & real(r8) :: irad real(r8) :: ifrac + real(r8) :: wbfeffmult(mgncol,nlev) ! wbf efficiency multiplier !shofer + real(r8) :: wbf_tag ! Arctic WBF multiplier value !shofer + + +! RaFSIP: dummy variables used to define the inputs/features and outputs/targets of the RaFSIP parameterization !GS/PG + real(r8) :: IWCRF1,RIMCRF1,TEMPRF1,RHIRF1,RIMRRF1,LWCRF1 + real(r8) :: IWCRF2, RIMCRF2, TEMPRF2, RHIRF2, LWCRF2 + real(r8) :: IWCRF3,RIMCRF3,TEMPRF3,RHIRF3,RIMRRF3,LWCRF3 + real(r8) :: IWCRF4, RIMCRF4, TEMPRF4, RHIRF4, LWCRF4 + real(r8) :: IWCRF5, RIMCRF5, TEMPRF5, RHIRF5, LWCRF5 + real(r8) :: FEATURES5(MDIM5),FEATURES6(MDIM6) + real(r8) :: YPRED1,YPRED2,YPRED3,YPRED4,YPRED5 + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! Return error message @@ -979,7 +1046,7 @@ subroutine micro_mg_tend ( & end do relhum = q / max(qvl, qsmall) - + relhumi = q / max(qvi, qsmall) !=============================================== ! set mtime here to avoid answer-changing @@ -1083,6 +1150,9 @@ subroutine micro_mg_tend ( & prodsnow = 0._r8 cmeout = 0._r8 + wbfeffmult = 1._r8 !shofer + wbf_tag = 0.5_r8 !shofer this line can be modified with a bash script + precip_frac = mincld lamc=0._r8 @@ -1163,6 +1233,62 @@ subroutine micro_mg_tend ( & nfice = 0._r8 + ! RaFSIP Inputs to the 4 RaFSIP models GS/PG + IWCRF1=0._r8 + LWCRF1=0._r8 + RHIRF1=0._r8 + TEMPRF1=0._r8 + RIMCRF1=0._r8 + RIMRRF1=0._r8 + IWCRF2=0._r8 + LWCRF2=0._r8 + RHIRF2=0._r8 + TEMPRF2=0._r8 + RIMCRF2=0._r8 + IWCRF3=0._r8 + RHIRF3=0._r8 + TEMPRF3=0._r8 + RIMCRF3=0._r8 + RIMRRF3=0._r8 + LWCRF3=0._r8 + IWCRF4=0._r8 + LWCRF4=0._r8 + RHIRF4=0._r8 + TEMPRF4=0._r8 + RIMCRF4=0._r8 + IWCRF5=0._r8 + LWCRF5=0._r8 + RHIRF5=0._r8 + TEMPRF5=0._r8 + RIMCRF5=0._r8 + !All inputs combined into an 1D array + FEATURES5(:)=0._r8 + FEATURES6(:)=0._r8 + !The predictions of the RaFSIP model + YPRED1=0._r8 + YPRED2=0._r8 + YPRED3=0._r8 + YPRED4=0._r8 + YPRED5=0._r8 + + ! RaFSIP zero process rates + IWC=0._r8 + RIMR=0._r8 + LWC=0._r8 + RIMC=0._r8 + TEMPK=0._r8 + RHI=0._r8 + BR_RATE=0._r8 + DS_RATE=0._r8 + HM_RATE=0._r8 + SIP_RATE=0._r8 + QIRSIP=0._r8 + QICSIP=0._r8 + + + +! RaFSIP +rafsip_on=.true. !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! droplet activation ! get provisional droplet number after activation. This is used for @@ -1370,6 +1496,14 @@ subroutine micro_mg_tend ( & endif + ! Modify WBF efficiency !shofer + ! wbf + ! shofer here wbfeffmult is applied everywhere + do i=1,mgncol + wbfeffmult(i,k) = wbf_tag + end do + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! get size distribution parameters based on in-cloud cloud water ! these calculations also ensure consistency between number and mixing ratio @@ -1571,12 +1705,12 @@ subroutine micro_mg_tend ( & qcic(1:mgncol,k), ncic(:,k), qsic(:,k), pgam(:,k), lamc(:,k), lams(:,k), n0s(:,k), & psacws(:,k), npsacws(:,k), mgncol) - if (do_cldice) then - call secondary_ice_production(t(:,k), psacws(:,k), msacwi(:,k), nsacwi(:,k), mgncol) - else + ! if (do_cldice) then !GS/PG RaFSIP + ! call secondary_ice_production(t(:,k), psacws(:,k), msacwi(:,k), nsacwi(:,k), mgncol) + ! else nsacwi(:,k) = 0.0_r8 msacwi(:,k) = 0.0_r8 - end if + ! end if call accrete_rain_snow(t(:,k), rho(:,k), umr(:,k), ums(:,k), unr(:,k), uns(:,k), & qric(:,k), qsic(:,k), lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), & @@ -1613,7 +1747,8 @@ subroutine micro_mg_tend ( & qvl(:,k), qvi(:,k), asn(:,k), qcic(1:mgncol,k), qsic(:,k), lams(:,k), n0s(:,k), & bergs(:,k), mgncol) - bergs(:,k)=bergs(:,k)*micro_mg_berg_eff_factor +! bergs(:,k)=bergs(:,k)*micro_mg_berg_eff_factor + bergs(:,k)=bergs(:,k)*micro_mg_berg_eff_factor*wbfeffmult(:,k) !shofer !+++PMC 12/3/12 - NEW VAPOR DEP/SUBLIMATION GOES HERE!!! if (do_cldice) then @@ -1622,7 +1757,8 @@ subroutine micro_mg_tend ( & icldm(:,k), rho(:,k), dv(:,k), qvl(:,k), qvi(:,k), & berg(:,k), vap_dep(:,k), ice_sublim(:,k), mgncol) - berg(:,k)=berg(:,k)*micro_mg_berg_eff_factor +! berg(:,k)=berg(:,k)*micro_mg_berg_eff_factor + berg(:,k)=berg(:,k)*micro_mg_berg_eff_factor*wbfeffmult(:,k) !shofer where (ice_sublim(:,k) < 0._r8 .and. qi(:,k) > qsmall .and. icldm(:,k) > mincld) nsubi(:,k) = sublim_factor*ice_sublim(:,k) / qi(:,k) * ni(:,k) / icldm(:,k) @@ -1636,6 +1772,240 @@ subroutine micro_mg_tend ( & !in fact, nothing in this entire file makes nsubc nonzero. nsubc(:,k) = 0._r8 + + ! Secondary Ice production (RaFSIP parameterization) !GS/PG + IF (rafsip_on) THEN + + DO i=1,mgncol + + !! First we define all the useful parameters that will be used as inputs to the parameterization + !The total ice water content in kg/kg + IWC(i,k) = qiic(i,k)+qsic(i,k) + !The total amount of cloud droplets rimed onto ice particles in kg/kg/s + RIMC(i,k) = psacws(i,k) + !The total amount of raindrops rimed onto ice particles in kg/kg/s + RIMR(i,k) = pracs(i,k) + !Ambient temperature in K + TEMPK(i,k) = t(i,k) + !Relative humidity with respect to ice + RHI(i,k) = relhumi(i,k) + !The total liquid water content in kg/kg + LWC(i,k) = qcic(i,k)+qric(i,k) + + + !Lower bounds + IF (RIMC(i,k).GT.0._r8.AND.IWC(i,k).GT.0._r8.AND.LWC(i,k).GT.0._r8.AND.RHI(i,k).GT.0._r8) THEN + + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! IF WE ARE WITHIN THE HALLETT-MOSSOP TEMPERATURE RANGE + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IF (t(i,k).LT.270.15_r8.AND.t(i,k).GE.265.15_r8) THEN + + !Activation of all secondary ice production processes within the HM + !temperature range, in the presence of rimed raindrops: forestALL + + IF (RIMR(i,k).GT.0._r8) THEN + IWCRF1 = LOG10(IWC(i,k)) + RIMCRF1 = LOG10(RIMC(i,k)) + RIMRRF1 = LOG10(RIMR(i,k)) + TEMPRF1 = LOG10(TEMPK(i,k)) + RHIRF1 = LOG10(RHI(i,k)) + LWCRF1 = LOG10(LWC(i,k)) + + !! Combine all features into one vector + FEATURES6(:) = (/ IWCRF1,RIMCRF1,TEMPRF1,RHIRF1,RIMRRF1,LWCRF1 /) +! PRINT*, "FEATURESALL=",FEATURES6 + + !This subroutine reads the 6 inputs and gives 5 predictions for + !the SIP rates due to BR (BR_RATE), HM (HM_RATE) and DS (DS_RATE), + !as well as the mass of cloud droplets (QICSIP) and raindrops (QIRSIP) + !rimed onto the ice particle that will be transferred to the cloud ice category. + + CALL runforestmulti(mdim6,max_nodes3,jbt,features6,ypred1,ypred2,ypred3,ypred4,ypred5, & + & leftchild3,rightchild3,splitfeat3,thresh3,out31,out32,out33,out34,out35) + + BR_RATE(i,k) = 10._r8**(ypred1) + BR_RATE(i,k) = MAX(BR_RATE(i,k),0._r8) + + HM_RATE(i,k) = 10._r8**(ypred2) + HM_RATE(i,k) = MAX(HM_RATE(i,k),0._r8) + + DS_RATE(i,k) = 10._r8**(ypred3) + DS_RATE(i,k) = MAX(DS_RATE(i,k),0._r8) + + !! Mass transfer from cloud droplets/raindrops to cloud ice if HM_RATE>0 and/or DS_RATE>0 + IF (HM_RATE(i,k).GT.0._r8) THEN + QICSIP(i,k) = 10._r8**(ypred4) + QICSIP(i,k) = MIN(QICSIP(i,k),0.01_r8*RIMC(i,k)) !RIMC=PSACWS, only max 1% of the rimed mass can be used for SIP + QICSIP(i,k) = MAX(QICSIP(i,k),0._r8) + !Remove the mass of rimed cloud droplets that is involved in SIP + PSACWS(i,k) = PSACWS(i,k) - QICSIP(i,k) + ENDIF !MASS TRANSFER + + IF (HM_RATE(i,k).GT.0._r8.OR.DS_RATE(i,k).GT.0._r8) THEN + QIRSIP(i,k) = 10._r8**(ypred5) + QIRSIP(i,k) = MIN(QIRSIP(i,k),0.01_r8*RIMR(i,k)) !RIMR=PRACS, only max 1% of the rimed mass can be used for SIP + QIRSIP(i,k) = MAX(QIRSIP(i,k),0._r8) + !Remove the mass of rimed raindrops that is involved in SIP + PRACS(i,k) = PRACS(i,k) - QIRSIP(i,k) + ENDIF !MASS TRANSFER + + + !Activation of the collisional break-up and the hallett-mossop process + !if temperature is between -8<=T<-3 C, in the absence of rimed raindrops: forestbrhm + + ELSE + + IWCRF2 = LOG10(IWC(i,k)) + RIMCRF2 = LOG10(RIMC(i,k)) + LWCRF2 = LOG10(LWC(i,k)) + TEMPRF2 = LOG10(TEMPK(i,k)) + RHIRF2 = LOG10(RHI(i,k)) + + !! Combine all features into one vector + FEATURES5(:) = (/ IWCRF2, RIMCRF2, TEMPRF2, RHIRF2, LWCRF2 /) +! PRINT*, "FEATURESBRHM",FEATURES5 + + !This subroutine reads the 5 inputs and gives 3 predictions for the + !SIP rates due to BR (BR_RATE) and HM (HM_RATE), as well as + !the mass of cloud droplets rimed onto the ice particle that will be + !transferred to the cloud ice category (QICSIP). + + CALL runforestriv(mdim5,max_nodes1,jbt,features5,ypred1,ypred2,ypred3,& + & leftchild1,rightchild1,splitfeat1,thresh1,out11,out12,out13) + + BR_RATE(i,k) = 10._r8**(ypred1) + BR_RATE(i,k) = MAX(BR_RATE(i,k),0._r8) + + HM_RATE(i,k) = 10._r8**(ypred2) + HM_RATE(i,k) = MAX(HM_RATE(i,k),0._r8) + + !! Mass transfer from cloud droplets to cloud ice if HM_RATE>0 + IF (HM_RATE(i,k).GT.0._r8) THEN + QICSIP(i,k) = 10._r8**(ypred3) + QICSIP(i,k) = MIN(QICSIP(i,k),0.01_r8*RIMC(i,k)) !RIMC=PSACWS, only max 1% of the rimed mass can be used for SIP + QICSIP(i,k) = MAX(QICSIP(i,k),0._r8) + !Remove the mass of rimed cloud droplets that is involved in SIP + PSACWS(i,k) = PSACWS(i,k) - QICSIP(i,k) + ENDIF !Mass transfer + + + ENDIF !RIMR>0... + + + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! FOR LOWER TEMPERATURES BETWEEN -20 AND -8 C + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ELSEIF (t(i,k).LT.265.15_r8.AND.t(i,k).GE.253.15_r8) THEN + + !Activation of the collisional break-up and the droplet shattering + !process in the presence of rimed raidrops: forestbrds + + IF (RIMR(i,k).GT.0._r8) THEN + IWCRF3 = LOG10(IWC(i,k)) + RIMCRF3 = LOG10(RIMC(i,k)) + RIMRRF3 = LOG10(RIMR(i,k)) + TEMPRF3 = LOG10(TEMPK(i,k)) + RHIRF3 = LOG10(RHI(i,k)) + LWCRF3 = LOG10(LWC(i,k)) + + !! Combine all features into one vector + FEATURES6(:) = (/ IWCRF3,RIMCRF3,TEMPRF3,RHIRF3,RIMRRF3,LWCRF3/) +! PRINT*, "FEATURESBRDS",FEATURES6 + + !This subroutine reads the 6 inputs and gives 3 predictions for the + !SIP rates due to BR (BR_RATE) and DS (DS_RATE), as well as + !the mass of raindrops rimed onto the ice particle that will be + !transferred to the cloud ice category (QIRSIP). + + CALL runforestriv(mdim6,max_nodes4,jbt,features6,ypred1,ypred2,ypred3, & + & leftchild4,rightchild4,splitfeat4,thresh4,out41,out42,out43) + + BR_RATE(i,k) = 10._r8**(ypred1) + BR_RATE(i,k) = MAX(BR_RATE(i,k),0._r8) + + DS_RATE(i,k) = 10._r8**(ypred2) + DS_RATE(i,k) = MAX(DS_RATE(i,k),0._r8) + + !! Mass transfer from cloud droplets/raindrops to cloud ice if HM_RATE>0 and RIMC,RIMR>0 + IF (DS_RATE(i,k).GT.0._r8) THEN + QIRSIP(i,k) = 10._r8**(ypred3) + QIRSIP(i,k) = MIN(QIRSIP(i,k),0.01_r8*RIMR(i,k)) !RIMR=PRACS, only max 1% of the rimed mass can be used for SIP + QIRSIP(i,k) = MAX(QIRSIP(i,k),0._r8) + !Remove the mass of rimed raindrops that is involved in SIP + PRACS(i,k) = PRACS(i,k) - QIRSIP(i,k) + ENDIF !Mass transfer + + !Activation of the collisional break-up process when temperature is below + !the HM range, in the absence of raidrops: forestbr + ELSE + + IWCRF4 = LOG10(IWC(i,k)) + RIMCRF4 = LOG10(RIMC(i,k)) + TEMPRF4 = LOG10(TEMPK(i,k)) + RHIRF4 = LOG10(RHI(i,k)) + LWCRF4 = LOG10(LWC(i,k)) + + !! Combine all features into one vector + FEATURES5(:) = (/ IWCRF4, RIMCRF4, TEMPRF4, RHIRF4, LWCRF4 /) +! PRINT*, "FEATURESBR",FEATURES5 + + !This subroutine reads the 5 inputs and predicts the SIP rate due to BR (BR_RATE) + CALL runforest(mdim5,max_nodes2,jbt,features5,ypred1,leftchild2,rightchild2, & + & splitfeat2,thresh2,out21) + + BR_RATE(i,k) = 10._r8**(ypred1) + BR_RATE(i,k) = MAX(BR_RATE(i,k),0._r8) + + ENDIF ! IF RIMR>0... + + + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! FOR WARMER TEMPERATURES BETWEEN -3 AND 0 C + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + !Activation of the collisional break-up process when temperature is warmer + !than -3 C, in the absence of raidrops: forestbr + ELSEIF (t(i,k).LE.273.15_r8.AND.t(i,k).GE.270.15_r8) THEN + + IWCRF5 = LOG10(IWC(i,k)) + RIMCRF5 = LOG10(RIMC(i,k)) + TEMPRF5 = LOG10(TEMPK(i,k)) + RHIRF5 = LOG10(RHI(i,k)) + LWCRF5 = LOG10(LWC(i,k)) + + !! Combine all features into one vector + FEATURES5(:) = (/ IWCRF5, RIMCRF5, TEMPRF5, RHIRF5, LWCRF5 /) +! PRINT*, "FEATURESBR",FEATURES5 + + !This subroutine reads the 5 inputs and predicts the SIP rate due to BR (BR_RATE) + CALL runforest(mdim5,max_nodes5,jbt,features5,ypred1,leftchild5,rightchild5, & + & splitfeat5,thresh5,out51) + + BR_RATE(i,k) = 10._r8**(ypred1) + BR_RATE(i,k) = MAX(BR_RATE(i,k),0._r8) + + + ENDIF !Temperature range + + ENDIF !lower bounds + + + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + !Combine the effect of all SIP processes into one SIP_RATE that will be added + !in the conservation law of ice crystals at the end of the model time-step + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SIP_RATE(i,k) = BR_RATE(i,k)+DS_RATE(i,k)+HM_RATE(i,k) + SIP_RATE(i,k) = MAX(SIP_RATE(i,k),0._r8) + SIP_RATE(i,k) = MIN(SIP_RATE(i,k),10._r8) !10 particles /kg/s is the maximum SIP rate in the training dataset + + !PRINT*, "SIP_RATE=",SIP_RATE(i,k), "BR_RATE=",BR_RATE(i,k), "HM_RATE=",HM_RATE(i,k), "DSRATE=",DS_RATE(i,k) + !PRINT*, "QIRSIP=",QIRSIP(i,k), "QICSIP=",QICSIP(i,k) + + END DO ! i =1, mgcol + + ENDIF !GS/PG RaFSIP + + end if !do_cldice !---PMC 12/3/12 @@ -1652,11 +2022,11 @@ subroutine micro_mg_tend ( & !------------------------------------------------------------------- dum = ((prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k)+ & - psacws(i,k)+bergs(i,k))*lcldm(i,k)+berg(i,k))*deltat + psacws(i,k)+bergs(i,k))*lcldm(i,k)+berg(i,k)+QICSIP(i,k)*lcldm(i,k))*deltat !GS/PG -RaFSIP if (dum.gt.qc(i,k)) then ratio = qc(i,k)/deltat/((prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+ & - msacwi(i,k)+psacws(i,k)+bergs(i,k))*lcldm(i,k)+berg(i,k))*omsm + msacwi(i,k)+psacws(i,k)+bergs(i,k)+QICSIP(i,k))*lcldm(i,k)+berg(i,k))*omsm prc(i,k) = prc(i,k)*ratio pra(i,k) = pra(i,k)*ratio mnuccc(i,k) = mnuccc(i,k)*ratio @@ -1665,6 +2035,7 @@ subroutine micro_mg_tend ( & psacws(i,k) = psacws(i,k)*ratio bergs(i,k) = bergs(i,k)*ratio berg(i,k) = berg(i,k)*ratio + QICSIP(i,k) = QICSIP(i,k)*ratio !RaFSIP qcrat(i,k) = ratio else qcrat(i,k) = 1._r8 @@ -1749,18 +2120,19 @@ subroutine micro_mg_tend ( & ! conservation of rain mixing ratio !------------------------------------------------------------------- - dum = ((-pre(i,k)+pracs(i,k)+mnuccr(i,k)+mnuccri(i,k))*precip_frac(i,k)- & + dum = ((-pre(i,k)+pracs(i,k)+mnuccr(i,k)+mnuccri(i,k)+QIRSIP(i,k))*precip_frac(i,k)- & !RaFSIP (pra(i,k)+prc(i,k))*lcldm(i,k))*deltat ! note that qrtend is included below because of instantaneous freezing/melt if (dum.gt.qr(i,k).and. & - (-pre(i,k)+pracs(i,k)+mnuccr(i,k)+mnuccri(i,k)).ge.qsmall) then + (-pre(i,k)+pracs(i,k)+mnuccr(i,k)+mnuccri(i,k)+QIRSIP(i,k)).ge.qsmall) then ratio = (qr(i,k)/deltat+(pra(i,k)+prc(i,k))*lcldm(i,k))/ & - precip_frac(i,k)/(-pre(i,k)+pracs(i,k)+mnuccr(i,k)+mnuccri(i,k))*omsm + precip_frac(i,k)/(-pre(i,k)+pracs(i,k)+mnuccr(i,k)+mnuccri(i,k)+QIRSIP(i,k))*omsm pre(i,k)=pre(i,k)*ratio pracs(i,k)=pracs(i,k)*ratio mnuccr(i,k)=mnuccr(i,k)*ratio mnuccri(i,k)=mnuccri(i,k)*ratio + QIRSIP(i,k)=QIRSIP(i,k)*ratio !RaFSIP end if end do @@ -1807,14 +2179,14 @@ subroutine micro_mg_tend ( & ! conservation of qi !------------------------------------------------------------------- - dum = ((-mnuccc(i,k)-mnucct(i,k)-mnudep(i,k)-msacwi(i,k))*lcldm(i,k)+(prci(i,k)+ & - prai(i,k))*icldm(i,k)-mnuccri(i,k)*precip_frac(i,k) & + dum = ((-mnuccc(i,k)-mnucct(i,k)-mnudep(i,k)-msacwi(i,k)-QICSIP(i,k))*lcldm(i,k)+(prci(i,k)+ & + prai(i,k))*icldm(i,k)-mnuccri(i,k)*precip_frac(i,k)-QIRSIP(i,k)*precip_frac(i,k) & -ice_sublim(i,k)-vap_dep(i,k)-berg(i,k)-mnuccd(i,k))*deltat if (dum.gt.qi(i,k)) then ratio = (qi(i,k)/deltat+vap_dep(i,k)+berg(i,k)+mnuccd(i,k)+ & (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k))*lcldm(i,k)+ & - mnuccri(i,k)*precip_frac(i,k))/ & + mnuccri(i,k)*precip_frac(i,k))+(QICSIP(i,k)*lcldm(i,k)+QIRSIP(i,k)*precip_frac(i,k))/ & !RaFSIP ((prci(i,k)+prai(i,k))*icldm(i,k)-ice_sublim(i,k))*omsm prci(i,k) = prci(i,k)*ratio prai(i,k) = prai(i,k)*ratio @@ -1836,13 +2208,13 @@ subroutine micro_mg_tend ( & else tmpfrz = 0._r8 end if - dum = ((-nnucct(i,k)-tmpfrz-nnudep(i,k)-nsacwi(i,k))*lcldm(i,k)+(nprci(i,k)+ & + dum = ((-nnucct(i,k)-tmpfrz-nnudep(i,k)-nsacwi(i,k))*lcldm(i,k)-(SIP_RATE(i,k)*lcldm(i,k))+(nprci(i,k)+ & nprai(i,k)-nsubi(i,k))*icldm(i,k)-nnuccri(i,k)*precip_frac(i,k)- & nnuccd(i,k))*deltat if (dum.gt.ni(i,k)) then ratio = (ni(i,k)/deltat+nnuccd(i,k)+ & - (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k))*lcldm(i,k)+ & + (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k))*lcldm(i,k)+(SIP_RATE(i,k)*lcldm(i,k))+ & nnuccri(i,k)*precip_frac(i,k))/ & ((nprci(i,k)+nprai(i,k)-nsubi(i,k))*icldm(i,k))*omsm nprci(i,k) = nprci(i,k)*ratio @@ -1963,22 +2335,22 @@ subroutine micro_mg_tend ( & tlat(i,k) = tlat(i,k)+((pre(i,k)*precip_frac(i,k)) & *xxlv+(prds(i,k)*precip_frac(i,k)+vap_dep(i,k)+ice_sublim(i,k)+mnuccd(i,k)+mnudep(i,k)*lcldm(i,k))*xxls+ & ((bergs(i,k)+psacws(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k))*lcldm(i,k)+(mnuccr(i,k)+ & - pracs(i,k)+mnuccri(i,k))*precip_frac(i,k)+berg(i,k))*xlf) + pracs(i,k)+mnuccri(i,k))*precip_frac(i,k)+berg(i,k)+QICSIP(i,k)*lcldm(i,k)+QIRSIP(i,k)*precip_frac(i,k))*xlf) qctend(i,k) = qctend(i,k)+ & (-pra(i,k)-prc(i,k)-mnuccc(i,k)-mnucct(i,k)-msacwi(i,k)- & - psacws(i,k)-bergs(i,k))*lcldm(i,k)-berg(i,k) + psacws(i,k)-bergs(i,k)-QICSIP(i,k))*lcldm(i,k)-berg(i,k) !RaFSIP if (do_cldice) then qitend(i,k) = qitend(i,k)+ & - (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k))*lcldm(i,k)+(-prci(i,k)- & + (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k)+QICSIP(i,k))*lcldm(i,k)+(-prci(i,k)- & prai(i,k))*icldm(i,k)+vap_dep(i,k)+berg(i,k)+ice_sublim(i,k)+ & - mnuccd(i,k)+mnuccri(i,k)*precip_frac(i,k) + mnuccd(i,k)+(mnuccri(i,k)+QIRSIP(i,k))*precip_frac(i,k) !RaFSIP end if qrtend(i,k) = qrtend(i,k)+ & (pra(i,k)+prc(i,k))*lcldm(i,k)+(pre(i,k)-pracs(i,k)- & - mnuccr(i,k)-mnuccri(i,k))*precip_frac(i,k) + mnuccr(i,k)-mnuccri(i,k)-QIRSIP(i,k))*precip_frac(i,k) !RaFSIP qstend(i,k) = qstend(i,k)+ & (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+(prds(i,k)+ & @@ -2045,8 +2417,9 @@ subroutine micro_mg_tend ( & npratot(i,k)=npra(i,k)*lcldm(i,k) nprc1tot(i,k)=nprc1(i,k)*lcldm(i,k) + ! for ice - nsacwitot(i,k)=nsacwi(i,k)*lcldm(i,k) + nsacwitot(i,k)=SIP_RATE(i,k)*lcldm(i,k) !GS/PG RaFSIP nsubitot(i,k)=nsubi(i,k)*icldm(i,k) nprcitot(i,k)=nprci(i,k)*icldm(i,k) npraitot(i,k)=nprai(i,k)*icldm(i,k) @@ -2067,7 +2440,7 @@ subroutine micro_mg_tend ( & else tmpfrz = 0._r8 end if - nitend(i,k) = nitend(i,k)+ nnuccd(i,k)+ & + nitend(i,k) = nitend(i,k)+ nnuccd(i,k) + SIP_RATE(i,k)*lcldm(i,k) + & !RaFSIP (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k))*lcldm(i,k)+(nsubi(i,k)-nprci(i,k)- & nprai(i,k))*icldm(i,k)+nnuccri(i,k)*precip_frac(i,k) end if @@ -2084,10 +2457,24 @@ subroutine micro_mg_tend ( & ! note that currently mtime = deltat !================================================================ - if (do_cldice .and. nitend(i,k).gt.0._r8.and.ni(i,k)+nitend(i,k)*deltat.gt.nimax(i,k)) then - nitncons(i,k) = nitncons(i,k) + nitend(i,k)-max(0._r8,(nimax(i,k)-ni(i,k))/deltat) !AL + ! if (do_cldice .and. nitend(i,k).gt.0._r8.and.ni(i,k)+nitend(i,k)*deltat.gt.nimax(i,k)) then + ! nitncons(i,k) = nitncons(i,k) + nitend(i,k)-max(0._r8,(nimax(i,k)-ni(i,k))/deltat) !AL + ! nitend(i,k)=max(0._r8,(nimax(i,k)-ni(i,k))/deltat) + ! end if + + + + !shofer--- + ! OS Also added the term from secondary ice formation + if (nnucct(i,k)+nnuccc(i,k)+nnudep(i,k).gt.0._r8) then + nimax(i,k) = nimax(i,k)+(nnucct(i,k)+nnuccc(i,k)+nnudep(i,k)+SIP_RATE(i,k))*lcldm(i,k)*deltat + end if + + if (do_cldice.and.nitend(i,k).gt.0._r8.and.ni(i,k)+nitend(i,k)*deltat.gt.nimax(i,k)) then + nitncons(i,k) = nitncons(i,k) + nitend(i,k)-max(0._r8,(nimax(i,k)-ni(i,k))/deltat) nitend(i,k)=max(0._r8,(nimax(i,k)-ni(i,k))/deltat) end if + !shofer--- end do diff --git a/src/chemistry/oslo_aero/NdParam.f b/src/chemistry/oslo_aero/NdParam.f new file mode 100644 index 0000000000..417a640a15 --- /dev/null +++ b/src/chemistry/oslo_aero/NdParam.f @@ -0,0 +1,731 @@ +!======================================================================= +! +! *** BLOCK DATA BLKPAR +! *** THIS SUBROUTINE PROVIDES INITIAL (DEFAULT) VALUES TO PROGRAM +! PARAMETERS VIA DATA STATEMENTS +! +! *** WRITTEN BY ATHANASIOS NENES +! *** MODIFIED BY PRASHANT KUMAR AND ATHANASIOS NENES +! *** MODIFIED FOR EC-EARTH BY TWAN VAN NOIJE AND ATHANASIOS NENES +! +!======================================================================= +! + BLOCK DATA BLKPAR +! + INCLUDE 'parametr.inc' +! + DATA AMA /29d-3/ ! Air molecular weight + DATA GRAV /9.81d0/ ! g constant + DATA RGAS /8.31d0/ ! Universal gas constant + DATA Dw /2.75d-10/ ! Water Molecule Diameter + DATA AMW /18d-3/ ! Water molecular weight + DATA DENW /1d3/ ! Water density + DATA DHV /2.25d6/ ! Water enthalpy of vaporization + DATA CPAIR /1.0061d3/ ! Air Cp + +! Data for FHH exponent calculation + + DATA D11 /-0.1907/ + DATA D12 /-1.6929/ + DATA D13 /1.4963/ + DATA D14 /-0.5644/ + DATA D15 /0.0711/ + ! for C2 + DATA D21 /-3.9310/ + DATA D22 /7.0906/ + DATA D23 /-5.3436/ + DATA D24 /1.8025/ + DATA D25 /-0.2131/ + ! for C3 + DATA D31 /8.4825/ + DATA D32 /-14.9297/ + DATA D33 /11.4552/ + DATA D34 /-3.9115/ + DATA D35 /0.4647/ + ! for C4 + DATA D41 /-5.1774/ + DATA D42 /8.8725/ + DATA D43 /-6.8527/ + DATA D44 /2.3514/ + DATA D45 /-0.2799/ +! + DATA MAXIT /30/ ! Max iterations for solution + DATA EPS /1d-5/ ! Convergence criterion +! + DATA PI /3.1415927d0/ ! Some constants + DATA ZERO /0d0/ + DATA GREAT /1D30/ + DATA SQ2PI /2.5066282746d0/ +! + DATA CCNSPST /.FALSE./ ! Internal consistency check + DATA FIRST_GAULEG /.TRUE./ +! +! *** END OF BLOCK DATA SUBPROGRAM ************************************* +! + END +!======================================================================= +!======================================================================= +! +! *** SUBROUTINE CCNSPEC +! *** THIS SUBROUTINE CALCULATES THE CCN SPECTRUM OF THE AEROSOL USING +! THE APPROPRIATE FORM OF KOHLER THEORY +! +! *** ORIGINALLY WRITTEN BY ATHANASIOS NENES FOR ONLY KOHLER PARTICLES +! *** MODIFIED BY PRASHANT KUMAR AND ATHANSIOS NENES TO INCLUDE +! *** ACTIVATION BY FHH PARTICLES +! +!======================================================================= +! + SUBROUTINE CCNSPEC (TPI,DPGI,SIGI,MODEI,TPARC,PPARC,NMODES, + & AKKI,A,B,SG) +! + INCLUDE 'parametr.inc' + DOUBLE PRECISION, INTENT(IN) :: TPI(NMODES), DPGI(NMODES), + & SIGI(NMODES), TPARC, PPARC, + & AKKI(NSMX), A, B + + INTEGER, INTENT(IN) :: MODEI(NMODES), NMODES +! + DOUBLE PRECISION, INTENT(OUT) :: SG(NSMX) + + DOUBLE PRECISION TP(NSMX) + DOUBLE PRECISION Dpcm + + NMD = NMODES ! Save aerosol params in COMMON + DO I=1,NMD + MODE(I) = MODEI(I) + DPG(I) = DPGI(I) + SIG(I) = SIGI(I) + TP(I) = TPI(I) + ACTFR(I)= 0d0 ! Activation fraction of each mode #AN 23.11.22 for NorESM + ENDDO +!C + TEMP = TPARC ! Save parcel props in COMMON + PRES = PPARC + CALL PROPS ! Thermophysical properties + AKOH = 4D0*AMW*SURT/RGAS/TEMP/DENW ! Kelvin parameter +!C + DO K=1,NMD + IF (MODE(K).EQ.1) THEN ! Kohler modes + PAR1 = 4D0/27D0/AKKI(K)/DPG(K)**3 + PAR2 = SQRT(PAR1*AKOH**3) + SG(K) = EXP(PAR2) - 1D0 + ELSEIF (MODE(K).EQ.2) THEN ! FHH modes + CALL DpcFHH(DPG(K),TPARC,A,B,Dpcm) + Dpc(K) = Dpcm + SG(K) = (AKOH/Dpc(K))+(-A*(((Dpc(K)-DPG(K))/(2*Dw))**(-B))) + ENDIF + ENDDO +!C +!C ** INITIALIZE: CALCULATE GAUSS QUADRATURE POINTS ********************* +!C + IF (FIRST_GAULEG) THEN + CALL GAULEG (XGS, WGS, Npgauss) + FIRST_GAULEG = .FALSE. + ENDIF + +! open(unit=667, file='stuffxxx', access='append', status='unknown') +! write(667,*) TEMP, PRES, AKOH, AMW, SURT, RGAS, DENW, SG +! close(667) +!C +!C *** END OF SUBROUTINE CCNSPEC **************************************** +!C + RETURN + END +!C======================================================================= +!C======================================================================= +!C +!C *** SUBROUTINE DpcFHH +!C *** THIS SUBROUTINE CALCULATES THE CRITICAL PARTICLE DIAMETER +!C ACCORDING TO THE FHH ADSOSPRTION ISOTHERM THEORY. +!C +!C *** WRITTEN BY PRASHANT KUMAR AND ATHANASIOS NENES +!C +!C======================================================================= +!C + SUBROUTINE DpcFHH(Ddry,TPARC,A,B,Dc) +!C + Include 'parametr.inc' + DOUBLE PRECISION Ddry,mu,mu1,mu2,mu3,X1,X2l,Dpcm,Dpcl,Dpcu, + &X3,F1,F2,X3l,X2u,X3u,FDpcl,FDpcu,FDpcm,X2m,X3m,Dc,A,B + + TEMP = TPARC + CALL PROPS + + mu=(4*SURT*AMW)/(RGAS*TEMP*DENW) + mu1=(mu*2*Dw)/((A*B)*((2*Dw)**(B+1))) + mu2=1/mu1 + mu3=1-(mu2**(1/(1+B))) + + Dpcl = 0 !Lower Limit + Dpcu = 10e-4 !Upper Limit + +100 X1 = mu2**(1/(1+B)) + X2l = Dpcl**(2/(1+B)) + X3l = X1*X2l + FDpcl=((Dpcl-X3l)/Ddry)-1 + + X1 = mu2**(1/(1+B)) + X2u = Dpcu**(2/(1+B)) + X3u = X1*X2u + FDpcu=((Dpcu-X3u)/Ddry)-1 + + Dpcm = (Dpcu+Dpcl)/2 + + X1= mu2**(1/(1+B)) + X2m= Dpcm**(2/(1+B)) + X3m= X1*X2m + FDpcm=((Dpcm-X3m)/Ddry)-1 + + + If ((FDpcl*FDpcm).Le.0) Then + + If (ABS(FDpcm).Le.10e-8) Then + Goto 200 + Else + Dpcl = Dpcl + Dpcu = Dpcm + goto 100 + End if + + Else If ((FDpcl*FDpcm).GE.0) Then + + If (ABS(FDpcm).Le.10e-8) Then + Goto 200 + Else + Dpcl = Dpcm + Dpcu = Dpcu + goto 100 + End if + + Else If ((FDpcl*FDpcm).Eq.0) Then + Goto 200 + End if + +200 Dc = Dpcm + + RETURN + END + +!C *** END OF SUBROUTINE DpcFHH *************************************** +!C======================================================================= +!C======================================================================= +!C +!C *** SUBROUTINE PDFACTIV +!C *** THIS SUBROUTINE CALCULATES THE CCN ACTIVATION FRACTION ACCORDING +!C TO THE Nenes and Seinfeld (2003) PARAMETERIZATION, WITH +!C MODIFICATION FOR NON-CONTUNUUM EFFECTS AS PROPOSED BY Fountoukis +!C and Nenes (2004). THIS ROUTINE CALCULATES FOR A PDF OF +!C UPDRAFT VELOCITIES. +!C +!C *** WRITTEN BY ATHANASIOS NENES +!C +!C======================================================================= +!C + SUBROUTINE PDFACTIV (WPARC,TP,AKK,A,B,ACCOM,SG,SIGW, + & TPARC,PPARC,NACT,ACF,MACF,NMODES,SMAX) ! Activation fraction of each mode #AN 23.11.22 for NorESM +!C + INCLUDE 'parametr.inc' + DOUBLE PRECISION, INTENT(IN) :: TPARC, WPARC, A, B, ACCOM, SIGW, + & TP(NSMX),AKK(NSMX),SG(NSMX) + INTEGER, INTENT(IN) :: NMODES +! DOUBLE PRECISION, INTENT(OUT) :: NACT, ACF(NMODES), SMAX ! Activation fraction of each mode #AN 23.11.22 for NorESM + DOUBLE PRECISION, INTENT(OUT) :: NACT, ACF(NMODES), MACF(NMODES), SMAX ! Activation fraction of each mode #AN 23.11.22 for NorESM + + DOUBLE PRECISION NACTI, DENOM + REAL PDF + +!C +!C *** Single updraft case +!C + IF (SIGW.LT.1e-10) THEN + + !C + !C *** Case where updraft is very small + !C + IF (WPARC.LE.1d-6) THEN + SMAX = 0d0 + NACT = 0d0 + ACF = 0d0 ! Activation fraction of each mode #AN 23.11.22 for NorESM + MACF = 0d0 ! Activation fraction of each mode #AN 23.11.22 for NorESM + RETURN + ENDIF + + CALL ACTIVATE (WPARC,TP,AKK,A,B,ACCOM,SG,NACT,SMAX) + ACF = ACTFr ! Activation fraction of each mode #AN 23.11.22 for NorESM + MACF = ACTFm +!C +!C *** PDF of updrafts +!C + ELSE + NACT = ZERO + SMAX = ZERO + DENOM = ZERO + ACF = ZERO ! Activation fraction of each mode #AN 23.11.22 for NorESM + MACF = ZERO ! Activation fraction of each mode #AN 23.11.22 for NorESM + PLIMT = 1e-3 ! Probability of High Updraft limit + PROBI = SQRT(-2.0*LOG(PLIMT*SIGW*SQ2PI)) + WHI = WPARC + SIGW*PROBI ! Upper updrft limit + WLO = 0.05 ! Low updrft limit + SCAL = 0.5*(WHI-WLO) ! Scaling for updrafts + !open(unit=667,file='pgaussxx',access='append',status='unknown') + DO I=1,Npgauss + WPI = WLO + SCAL*(1.0-XGS(i)) ! Updraft + CALL ACTIVATE (WPI,TP,AKK,A,B,ACCOM,SG,NACTI,SMAXI) ! # of drops + PDF = (1.0/SQ2PI/SIGW)*EXP(-0.5*((WPI-WPARC)/SIGW)**2) ! Prob. of updrafts + NACT = NACT + WGS(i)*(PDF*NACTI) ! Integral for drops + SMAX = SMAX + WGS(i)*(PDF*SMAXI) ! Integral for Smax + ACF = ACF + WGS(i)*(PDF*ACTFr) ! Activation fraction of each mode #AN 23.11.22 for NorESM + MACF = MACF + WGS(i)*(PDF*ACTFm) ! Activation fraction of each mode #AN 23.11.22 for NorESM + DENOM = DENOM + WGS(i)*PDF + IF (PDF.LT.PLIMT) GOTO 100 + !write(667,*) NpGauss, i, nacti, smaxi + ENDDO + 100 NACT = NACT/DENOM + SMAX = SMAX/DENOM + ACF = ACF /DENOM ! Activation fraction of each mode #AN 23.11.22 for NorESM + MACF = MACF /DENOM ! Activation fraction of each mode #AN 23.11.22 for NorESM + !close(667) + ENDIF +! ACF=0.1D0 +! MACF=0.5D0 +!C + RETURN +!C +!C *** END OF SUBROUTINE PDFACTIV *************************************** +!C + END + +!C======================================================================= +!C======================================================================= +!C +!C *** SUBROUTINE ACTIVATE +!C *** THIS SUBROUTINE CALCULATES THE CCN ACTIVATION FRACTION ACCORDING +!C TO THE Nenes and Seinfeld (2003) PARAMETERIZATION, WITH +!C MODIFICATION FOR NON-CONTUNUUM EFFECTS AS PROPOSED BY Fountoukis +!C and Nenes (in preparation). +!C +!C *** WRITTEN BY ATHANASIOS NENES FOR KOHLER PARTICLES +!C *** MODIFIED BY PRASHANT KUMAR AND ATHANASIOS NENES TO INCLUDE FHH +!C PARTICLES +!C +!C======================================================================= +!C + SUBROUTINE ACTIVATE (WPARC,TP,AKK,A,B,ACCOM,SG,NDRPL,SMAX) + INCLUDE 'parametr.inc' + DOUBLE PRECISION NDRPL, WPARCEL,A,B,ACCOM,BET2,BETA + DOUBLE PRECISION TP(NSMX),AKK(NSMX),SG(NSMX) + DOUBLE PRECISION C1, C2, C3, C4, X_FHH +!C +!C *** Setup common block variables +!C + PRESA = PRES/1.013d5 ! Pressure (Pa) + DV = (0.211d0/PRESA)*(TEMP/273d0)**1.94 + DV = DV*1d-4 ! Water vapor diffusivity in air + DBIG = 5.0d-6 + DLOW = 0.207683*((ACCOM)**(-0.33048)) + DLOW = DLOW*1d-6 +!C +!C Compute an average diffusivity Dv as a function of ACCOM +!C + COEF = ((2*PI*AMW/(RGAS*TEMP))**0.5) + DV = (DV/(DBIG-DLOW))*((DBIG-DLOW)-(2*DV/ACCOM)*COEF* + & (DLOG((DBIG+(2*DV/ACCOM)*COEF)/(DLOW+(2*DV/ACCOM)* + & COEF)))) ! Non-continuum effects + + WPARCEL = WPARC +! +! *** Setup constants +! + ALFA = GRAV*AMW*DHV/CPAIR/RGAS/TEMP/TEMP - GRAV*AMA/RGAS/TEMP + BET1 = PRES*AMA/PSAT/AMW + AMW*DHV*DHV/CPAIR/RGAS/TEMP/TEMP + BET2 = RGAS*TEMP*DENW/PSAT/DV/AMW/4d0 + + & DHV*DENW/4d0/AKA/TEMP*(DHV*AMW/RGAS/TEMP - 1d0) + BETA = 0.5d0*PI*BET1*DENW/BET2/ALFA/WPARC/DAIR + CF1 = 0.5*(((1/BET2)/(ALFA*WPARC))**0.5) + CF2 = AKOH/3d0 +! +!C DETERMINATION OF EXPONENT FOR FHH PARTICLES +! + C1 = (D11)+(D12/A)+(D13/(A*A))+(D14/(A*A*A))+(D15/(A*A*A*A)) + C2 = (D21)+(D22/A)+(D23/(A*A))+(D24/(A*A*A))+(D25/(A*A*A*A)) + C3 = (D31)+(D32/A)+(D33/(A*A))+(D34/(A*A*A))+(D35/(A*A*A*A)) + C4 = (D41)+(D42/A)+(D43/(A*A))+(D44/(A*A*A))+(D45/(A*A*A*A)) + X_FHH = (C1) + (C2/B) + (C3/(B*B)) + (C4/(B*B*B)) +! +! *** INITIAL VALUES FOR BISECTION ************************************* +! + X1 = 1.0d-5 ! Min cloud supersaturation -> 0 + CALL SINTEGRAL (X1,NDRPL,WPARCEL,TP,X_FHH,BET2,SG, + & SINTEG1,SINTEG2,SINTEG3) + Y1 = (SINTEG1*CF1+SINTEG2*CF2+SINTEG3*CF1)*BETA*X1 - 1d0 +! + X2 = 0.1d0 ! MAX cloud supersaturation = 10% + CALL SINTEGRAL (X2,NDRPL,WPARCEL,TP,X_FHH,BET2,SG, + & SINTEG1,SINTEG2,SINTEG3) + Y2 = (SINTEG1*CF1+SINTEG2*CF2+SINTEG3*CF1)*BETA*X2 - 1d0 +! +! *** PERFORM BISECTION ************************************************ +! +20 DO 30 I=1,MAXIT + X3 = 0.5*(X1+X2) + CALL SINTEGRAL (X3,NDRPL,WPARCEL,TP,X_FHH,BET2,SG, + & SINTEG1,SINTEG2,SINTEG3) + Y3 = (SINTEG1*CF1+SINTEG2*CF2+SINTEG3*CF1)*BETA*X3 - 1d0 +! + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) .LE. ZERO) THEN ! (Y1*Y3 .LE. ZERO) + Y2 = Y3 + X2 = X3 + ELSE + Y1 = Y3 + X1 = X3 + ENDIF +! + IF (ABS(X2-X1) .LE. EPS*X1) GOTO 40 + NITER = I + +30 CONTINUE + +! *** CONVERGED ; RETURN *********************************************** +40 X3 = 0.5*(X1+X2) +! + CALL SINTEGRAL (X3,NDRPL,WPARCEL,TP,X_FHH,BET2,SG, + & SINTEG1,SINTEG2,SINTEG3) + Y3 = (SINTEG1*CF1+SINTEG2*CF2+SINTEG3*CF1)*BETA*X3 - 1d0 + + SMAX = X3 + + RETURN +!C +!C *** END OF SUBROUTINE ACTIVATE *************************************** +!C + END +!C======================================================================= +!C======================================================================= +!C +!C *** SUBROUTINE SINTEGRAL +!C *** THIS SUBROUTINE CALCULATES THE CONDENSATION INTEGRALS, ACCORDING +!C TO THE POPULATION SPLITTING ALGORITHM AND THE SUBSEQUENT VERSIONS: +!C +!C - Nenes and Seinfeld (2003) Population Splitting +!C - Fountoukis and Nenes (2004) Modal formulation +!C - Barahona and Nenes (2010) Approach for large CCN +!C - Morales and Nenes (2014) Population Splitting revised +!C +!C *** WRITTEN BY ATHANASIOS NENES for Kohler Particles +!C *** MODFIFIED BY PRASHANT KUMAR AND ATHANASIOS NENES TO INCLUDE FHH +!C PARTICLES +!C======================================================================= +!C + SUBROUTINE SINTEGRAL (SPAR, SUMMA, WPARCEL, TP, XFHH, BET2, SG, + & SUM, SUMMAT, SUMFHH) +!C + INCLUDE 'parametr.inc' + DOUBLE PRECISION SUM, SUMMAT, SUMMA, Nd(NSMX),WPARCEL,TP(NSMX), + & INTEG1(NSMX),INTEG2(NSMX),SG(NSMX),A,B,BET2 + & ,SUMFHH,INTEG1F(NSMX),NdF(NSMX), XFHH + + REAL ERF1,ERF2,ERF3,ERF4,ERF5,ERF6,ERF4F,ERF5F,ERF66F + REAL ORISM1, ORISM2, ORISM3, ORISM4, ORISM5,ORISM6 + REAL intaux2, intaux1p1, intaux1p2, DLGSP1,DLGSP2 + REAL scrit +!C + REAL ORISM1F, ORISM2F, ORISM3F, ORISM4F, ORISM5F, + & ORISM6F, ORISM7F, ORISM8F, ORISM9F, ORISM10F, + & ORISM11F, ORISM66F + REAL ERFMS,ORISMS +! + SQTWO = SQRT(2d0) +!C +!C ** Population Splitting -- Modified by Ricardo Morales 2014 + + DESCR = 1d0 - (16d0/9d0)*ALFA*WPARCEL*BET2*(AKOH/SPAR**2)**2 + IF (DESCR.LE.0d0) THEN + CRIT2 = .TRUE. + scrit = ((16d0/9d0)*ALFA*WPARCEL*BET2*(AKOH**2))**(0.25d0) ! Scrit - (only for DELTA < 0 ) + RATIO = (2.0d7/3.0)*AKOH*(SPAR**(-0.3824)-scrit**(-0.3824)) ! Computing sp1 and sp2 (sp1 = sp2) + RATIO = 1/SQTWO + RATIO + IF (RATIO.GT.1.0) RATIO = 1.0 + SSPLT2 = SPAR*RATIO + ELSE + CRIT2 = .FALSE. + SSPLT1 = 0.5d0*(1d0-SQRT(DESCR)) ! min root --> sp1 + SSPLT2 = 0.5d0*(1d0+SQRT(DESCR)) ! max root --> sp2 + SSPLT1 = SQRT(SSPLT1)*SPAR ! Multiply ratios with Smax + SSPLT2 = SQRT(SSPLT2)*SPAR + ENDIF +!C + SSPLT = SSPLT2 ! Store Ssplit in COMMON +!C +!C *** Computing the condensation integrals I1 and I2 +!C + SUM = 0.0d0 !Contribution of integral 1 for Kohler + SUMMAT = 0.0d0 !Contribution of integral 2 for kohler + SUMMA = 0.0d0 !Variable that stores all droplets + SUMFHH = 0.0d0 !Contribution of FHH integral +!C + DO J = 1, NMD +!C + IF (MODE(J).EQ.1) THEN ! Kohler modes +!C + DLGSG = DLOG(SIG(J)) !ln(sigmai) + DLGSP = DLOG(SG(J)/SPAR) !ln(sg/smax) + DLGSP2 = DLOG(SG(J)/SSPLT2) !ln(sg/sp2) +!C + ORISM1 = 2.d0*DLGSP2/(3.d0*SQTWO*DLGSG) ! u(sp2) + ORISM2 = ORISM1 - 3.d0*DLGSG/(2.d0*SQTWO) ! u(sp2)-3ln(sigmai)/(2sqrt(2) + ORISM5 = 2.d0*DLGSP/(3.d0*SQTWO*DLGSG) ! u(smax) + ORISM3 = ORISM5 - 3.d0*DLGSG/(2.d0*SQTWO) ! u(smax)-3ln(sigmai)/(2sqrt(2) + DEQ = AKOH*2d0/SG(j)/3d0/SQRT(3d0) ! Dp0 = Dpc/sqrt(3) - Equilibrium diameter + + ERF2 = erfp(ORISM2) + ERF3 = erfp(ORISM3) + + INTEG2(J) = (EXP(9D0/8D0*DLGSG*DLGSG)*TP(J)/SG(J))* + & (ERF2 - ERF3) ! I2(sp2,smax) + + IF (CRIT2) THEN + + ORISM6 = (SQTWO*DLGSP2/3d0/DLGSG)-(1.5d0*DLGSG/SQTWO) + ERF6 = erfp(ORISM6) + + INTEG1(J) = 0.0d0 + DW3 = TP(j)*DEQ*EXP(9D0/8D0*DLGSG*DLGSG)* ! 'inertially' limited particles + & (1d0-ERF6)*((BET2*ALFA*WPARCEL)**0.5d0) + + ELSE + + EKTH = EXP(9D0/2d0*DLGSG*DLGSG) + DLGSP1 = DLOG(SG(J)/SSPLT1) ! ln(sg/sp1) + ORISM4 = ORISM1 + 3.d0*DLGSG/SQTWO ! u(sp2) + 3ln(sigmai)/sqrt(2) + ERF1 = erfp(ORISM1) + ERF4 = erfp(ORISM4) + + intaux1p2 = TP(J)*SPAR*((1-ERF1) - + & 0.5d0*((SG(J)/SPAR)**2)*EKTH*(1-ERF4)) ! I1(0,sp2) + + ORISM1 = 2.d0*DLGSP1/(3.d0*SQTWO*DLGSG) ! u(sp1) + ORISM4 = ORISM1 + 3.d0*DLGSG/SQTWO ! u(sp1) + 3ln(sigmai)/sqrt(2) + ORISM6 = (SQTWO*DLGSP1/3d0/DLGSG)-(1.5d0*DLGSG/SQTWO) + + ERF1 = erfp(ORISM1) + ERF4 = erfp(ORISM4) + ERF6 = erfp(ORISM6) + + intaux1p1 = TP(J)*SPAR*((1-ERF1) - + & 0.5d0*((SG(J)/SPAR)**2)*EKTH*(1-ERF4)) ! I1(0,sp1) + + INTEG1(J) = (intaux1p2-intaux1p1) ! I1(sp1,sp2) = I1(0,sp2) - I1(0,sp1) +! + DW3 = TP(j)*DEQ*EXP(9D0/8D0*DLGSG*DLGSG)* ! 'inertially' limited particles. + & (1d0-ERF6)*((BET2*ALFA*WPARCEL)**0.5d0) + + ENDIF + +!C *** Calculate number of Drops + + ERF5 = erfp(ORISM5) +! + Nd(J) = (TP(J)/2.0)*(1.0-ERF5) + ACTFr(J) = Nd(J)/MAX(TP(J),1d-30) ! Activation fraction of each mode #AN 23.11.22 for NorESM + DLGSPM = DLGSP-4.5*DLGSG*DLGSG + ORISMS =(2.0*DLGSPM/(3.0*sqtwo*dlgsg)) + ERFMS = erfp(ORISMS) + ACTFm(J) = 0.5*(1.0-ERFMS) ! Activation fraction of each mode #AN 23.11.22 for NorESM + SUM = SUM + INTEG1(J) + DW3 !SUM OF INTEGRAL 1 FOR KOHLER + SUMMAT = SUMMAT + INTEG2(J) !SUM OF INTEGRAL 2 FOR KOHLER + SUMMA = SUMMA + Nd(J) !SUM OF ACTIVATED KOHLER PARTICLES + +!C + ELSEIF (MODE(J).EQ.2) THEN ! FHH modes +!C + DLGSGF = DLOG(SIG(J)) ! ln(sigma,i) + DLGSPF = DLOG(SG(J)/SPAR) ! ln(sg/smax) + ORISM1F = (SG(J)*SG(J))/(SPAR*SPAR) ! (sg/smax)^2 + ORISM2F = EXP(2D0*XFHH*XFHH*DLGSGF*DLGSGF) ! exp(term) + ORISM3F = SQTWO*XFHH*DLGSGF ! sqrt(2).x.ln(sigma,i) + ORISM4F = DLGSPF/(-1*ORISM3F) ! Umax + ORISM5F = ORISM3F - ORISM4F + ERF5F = erfp(ORISM5F) + ORISM6F = ERF5F + ORISM7F = ORISM6F + 1 + ORISM8F = 0.5*ORISM1F*ORISM2F*ORISM7F + ERF4F = erfp(ORISM4F) + ORISM9F = ORISM8F + ERF4F - 1 + + INTEG1F(J) =-1*TP(J)*SPAR*ORISM9F +!C +!C *** Calculate number of drops activated by FHH theory +!C + ERF4F = erfp(ORISM4F) + + NdF(J) = (TP(J)/2.0)*(1-ERF4F) + ACTFr(J) = NdF(J)/MAX(TP(J),1d-30) ! Activation fraction of each mode #AN 23.11.22 for NorESM + DLGSPM = DLGSP-4.5*DLGSG*DLGSG + ORISMS =(2.0*DLGSPM/(3.0*sqtwo*dlgsg)) + ERFMS = erfp(ORISMS) + ACTFm(J) = 0.5*(1.0-ERFMS) ! Activation fraction of each mode #AN 23.11.22 for NorESM +! ACTFm(J) = 0.5*(1.0-erfp(2.0*DLGSPM/(3.0*sqtwo*dlgsg))) + + SUMFHH = SUMFHH + INTEG1F(J) !Sum of Integral 1 for FHH + SUMMA = SUMMA + NdF(J) !Sum of ACTIVATED Kohler + FHH particles + + ENDIF + + ENDDO + RETURN +!C + END +!C======================================================================= +!C======================================================================= +!C +!C *** SUBROUTINE PROPS +!C *** THIS SUBROUTINE CALCULATES THE THERMOPHYSICAL PROPERTIES +!C +!C *** WRITTEN BY ATHANASIOS NENES +!C +!C======================================================================= +!C + SUBROUTINE PROPS + INCLUDE 'parametr.inc' + REAL VPRES, SFT +!C + PRESA = PRES/1.013d5 ! Pressure (Pa) + DAIR = PRES*AMA/RGAS/TEMP ! Air density + AKA = (4.39+0.071*TEMP)*1d-3 ! Air thermal conductivity + PSAT = VPRES(SNGL(TEMP))*(1e5/1.0d3) ! Saturation vapor pressure + SURT = SFT(SNGL(TEMP)) ! Surface Tension for water (J m-2) +!C + RETURN +!C +!C *** END OF SUBROUTINE PROPS ****************************************** +!C + END +!C======================================================================= +!C======================================================================= +!C +!C *** FUNCTION VPRES +!C *** THIS FUNCTION CALCULATES SATURATED WATER VAPOUR PRESSURE AS A +!C FUNCTION OF TEMPERATURE. VALID FOR TEMPERATURES BETWEEN -50 AND +!C 50 C. +!C +!C========================= ARGUMENTS / USAGE =========================== +!C +!C INPUT: +!C [T] +!C REAL variable. +!C Ambient temperature expressed in Kelvin. +!C OUTPUT: +!C [VPRES] +!C REAL variable. +!C Saturated vapor pressure expressed in mbar. +!C +!C======================================================================= +!C + REAL FUNCTION VPRES (T) + REAL A(0:6), T + DATA A/6.107799610E+0, 4.436518521E-1, 1.428945805E-2, + & 2.650648471E-4, 3.031240396E-6, 2.034080948E-8, + & 6.136820929E-11/ + + TTEMP = T-273 + VPRES = A(6)*TTEMP + DO I=5,1,-1 + VPRES = (VPRES + A(I))*TTEMP + ENDDO + VPRES = VPRES + A(0) + RETURN + END +!C======================================================================= +!C======================================================================= +!C +!C *** FUNCTION SFT +!C *** THIS FUNCTION CALCULATES WATER SURFACE TENSION AS A +!C FUNCTION OF TEMPERATURE. VALID FOR TEMPERATURES BETWEEN -40 AND +!C 40 C. +!C +!C ======================== ARGUMENTS / USAGE =========================== +!C +!C INPUT: +!C [T] +!C REAL variable. +!C Ambient temperature expressed in Kelvin. +!C +!C OUTPUT: +!C [SFT] +!C REAL variable. +!C Surface Tension expressed in J m-2. +!C +!C======================================================================= +!C + REAL FUNCTION SFT (T) + REAL T +!C + TPARS = T-273 + SFT = 0.0761-1.55e-4*TPARS +!C + RETURN + END +!C======================================================================= +!C *********************************************************************** +!C + SUBROUTINE GAULEG (X,W,N) +!C +!C Calculation of points and weights for N point GAUSS integration +!C *********************************************************************** + DIMENSION X(N), W(N) + PARAMETER (EPS=1.E-6) + PARAMETER (X1=-1.0, X2=1.0) +!C +!C Calculation +!C + M=(N+1)/2 + XM=0.5d0*(X2+X1) + XL=0.5d0*(X2-X1) + DO 12 I=1,M + Z=COS(3.141592654d0*(I-.25d0)/(N+.5d0)) +1 CONTINUE + P1=1.d0 + P2=0.d0 + DO 11 J=1,N + P3=P2 + P2=P1 + P1=((2.d0*J-1.)*Z*P2-(J-1.d0)*P3)/J +11 CONTINUE + PP=N*(Z*P1-P2)/(Z*Z-1.d0) + Z1=Z + Z=Z1-P1/PP + IF(ABS(Z-Z1).GT.EPS)GO TO 1 + X(I)=XM-XL*Z + X(N+1-I)=XM+XL*Z + W(I)=2.d0*XL/((1.d0-Z*Z)*PP*PP) + W(N+1-I)=W(I) +12 CONTINUE + RETURN + END + +!C======================================================================= +!C +!C *** REAL FUNCTION erfp +!C *** THIS SUBROUTINE CALCULATES THE ERROR FUNCTION USING A +!C *** POLYNOMIAL APPROXIMATION +!C +!C======================================================================= +!C + REAL*8 FUNCTION erfp(x) + REAL :: x + REAL*8 :: AA(4), axx, y + DATA AA /0.278393d0,0.230389d0,0.000972d0,0.078108d0/ + + y = dabs(dble(x)) + axx = 1.d0 + y*(AA(1)+y*(AA(2)+y*(AA(3)+y*AA(4)))) + axx = axx*axx + axx = axx*axx + axx = 1.d0 - (1.d0/axx) + if(x.le.0.) then + erfp = -axx + else + erfp = axx + endif + RETURN + END FUNCTION diff --git a/src/chemistry/oslo_aero/hetfrz_classnuc_oslo.F90 b/src/chemistry/oslo_aero/hetfrz_classnuc_oslo.F90 index aadea38e2d..d54977aba9 100644 --- a/src/chemistry/oslo_aero/hetfrz_classnuc_oslo.F90 +++ b/src/chemistry/oslo_aero/hetfrz_classnuc_oslo.F90 @@ -29,6 +29,9 @@ module hetfrz_classnuc_oslo use hetfrz_classnuc, only: hetfrz_classnuc_init, hetfrz_classnuc_calc use oslo_utils, only: CalculateNumberConcentration, calculateNumberMedianRadius use aerosoldef, only : MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_OMBC_INTMIX_COAT_AIT + +use phys_grid, only: get_rlat_all_p !jks 061119, this function will return an array with column latitudes + implicit none private save @@ -200,6 +203,9 @@ subroutine hetfrz_classnuc_oslo_init(mincld_in) call addfld('bc_num', (/ 'lev' /), 'A', '#/cm3', 'total bc number') call addfld('dst1_num', (/ 'lev' /), 'A', '#/cm3', 'total dst1 number') call addfld('dst3_num', (/ 'lev' /), 'A', '#/cm3', 'total dst3 number') + call addfld('bc_num_scaled', (/ 'lev' /), 'A', '#/cm3', 'total bc number scaled by inp_mult') ! jks + call addfld('dst1_num_scaled', (/ 'lev' /), 'A', '#/cm3', 'total dst1 number scaled by inp_mult') ! jks + call addfld('dst3_num_scaled', (/ 'lev' /), 'A', '#/cm3', 'total dst3 number scaled by inp_mult') !jks call addfld('bcc_num', (/ 'lev' /), 'A', '#/cm3', 'coated bc number') call addfld('dst1c_num', (/ 'lev' /), 'A', '#/cm3', 'coated dst1 number') call addfld('dst3c_num', (/ 'lev' /), 'A', '#/cm3', 'coated dst3 number') @@ -213,7 +219,7 @@ subroutine hetfrz_classnuc_oslo_init(mincld_in) call addfld('bc_c1_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne bc number') call addfld('dst_c1_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne dst1 number') call addfld('dst_c3_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne dst3 number') - + call addfld('fn_bc_c1_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne bc number derived from fn') call addfld('fn_dst_c1_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne dst1 number derived from fn') call addfld('fn_dst_c3_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne dst3 number derived from fn') @@ -267,6 +273,9 @@ subroutine hetfrz_classnuc_oslo_init(mincld_in) call add_default('bc_num', 1, ' ') call add_default('dst1_num', 1, ' ') call add_default('dst3_num', 1, ' ') + call add_default('bc_num_scaled', 1, ' ') !jks, make sure these fields are included to verify + call add_default('dst1_num_scaled', 1, ' ') !jks + call add_default('dst3_num_scaled', 1, ' ') !jks call add_default('bcc_num', 1, ' ') call add_default('dst1c_num', 1, ' ') call add_default('dst3c_num', 1, ' ') @@ -280,7 +289,7 @@ subroutine hetfrz_classnuc_oslo_init(mincld_in) call add_default('bc_c1_num', 1, ' ') call add_default('dst_c1_num', 1, ' ') call add_default('dst_c3_num', 1, ' ') - + call add_default('fn_bc_c1_num', 1, ' ') call add_default('fn_dst_c1_num', 1, ' ') call add_default('fn_dst_c3_num', 1, ' ') @@ -302,7 +311,7 @@ subroutine hetfrz_classnuc_oslo_init(mincld_in) call add_default('BCFREZDEP', 1, ' ') call add_default('NIMIX_IMM', 1, ' ') - call add_default('NIMIX_CNT', 1, ' ') + call add_default('NIMIX_CNT', 1, ' ') call add_default('NIMIX_DEP', 1, ' ') call add_default('DSTNIDEP', 1, ' ') @@ -374,8 +383,9 @@ subroutine hetfrz_classnuc_oslo_calc( & real(r8),intent(in) :: volumeCore(pcols,pver,nmodes_oslo) real(r8),intent(in) :: volumeCoat(pcols,pver,nmodes_oslo) + type(physics_buffer_desc), pointer :: pbuf(:) - + ! local workspace ! outputs shared with the microphysics via the pbuf @@ -388,7 +398,7 @@ subroutine hetfrz_classnuc_oslo_calc( & real(r8) :: rho(pcols,pver) ! air density (kg m-3) - real(r8), pointer :: ast(:,:) + real(r8), pointer :: ast(:,:) real(r8) :: lcldm(pcols,pver) @@ -405,6 +415,13 @@ subroutine hetfrz_classnuc_oslo_calc( & real(r8) :: coated_aer_num(pcols,pver,3) real(r8) :: uncoated_aer_num(pcols,pver,3) + ! jks adding dummy variables for hetfrz_classnuc_calc + real(r8) :: total_interstitial_aer_num_scaled(pcols,pver,3) + real(r8) :: total_cloudborne_aer_num_scaled(pcols,pver,3) + real(r8) :: total_aer_num_scaled(pcols,pver,3) + real(r8) :: coated_aer_num_scaled(pcols,pver,3) + real(r8) :: uncoated_aer_num_scaled(pcols,pver,3) + real(r8) :: fn_cloudborne_aer_num(pcols,pver,3) @@ -427,7 +444,7 @@ subroutine hetfrz_classnuc_oslo_calc( & real(r8) :: numice10s_imm_bc(pcols,pver) !++oslo aerosol specific - real(r8) :: qaercwpt(pcols,pver,pcnst) + real(r8) :: qaercwpt(pcols,pver,pcnst) real(r8) :: CloudnumberConcentration(pcols,pver,0:nmodes_oslo) real(r8) :: numberMedianRadius(pcols,pver,nmodes_oslo) !--oslo aerosol specific @@ -435,9 +452,14 @@ subroutine hetfrz_classnuc_oslo_calc( & real(r8) :: na500(pcols,pver) real(r8) :: tot_na500(pcols,pver) + ! Declare new objects ! jks + real(r8), allocatable :: rlats(:) ! jks, define as an allocatable because the size ncol is not defined yet + real(r8) :: inp_mult ! jks I think that we just need a single float to do the job here + real(r8) :: inp_tag ! jks I think that we just need a single float to do the job here + character(128) :: errstring ! Error status - integer :: n, m, kk + integer :: n, m, kk !------------------------------------------------------------------------------- associate( & @@ -448,6 +470,11 @@ subroutine hetfrz_classnuc_oslo_calc( & nc => state%q(:pcols,:pver,numliq_idx), & pmid => state%pmid ) + allocate(rlats(ncol)) ! jks, must allocate before referencing because rlats object has no location + call get_rlat_all_p(lchnk, ncol, rlats) ! jks 191104, get rlats array + + inp_tag = 0.001_r8 ! jks 0.001.0014 this string is to be picked out and replaced with a [0,1] r8 + itim_old = pbuf_old_tim_idx() call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) @@ -494,25 +521,37 @@ subroutine hetfrz_classnuc_oslo_calc( & !Get estimate of number of aerosols inside clouds - call calculateNumberConcentration(ncol, aer_cb, rho, CloudnumberConcentration) + call calculateNumberConcentration(ncol, aer_cb(:,:,:,lchnk), rho, CloudnumberConcentration) call calculateNumberMedianRadius(numberConcentration, volumeConcentration, lnSigma, numberMedianRadius, ncol) !End estimate of number inside clouds ! output aerosols as reference information for heterogeneous freezing do i = 1, ncol + ! Set inp multiplier if latitude is in the Arctic jks 061119 + inp_mult = 1.0_r8 + ! shofer remove latitudinal constraint + ! if (rlats(i)*0.001._r8/3.14159_r8.gt.+66.66667_r8) inp_mult=inp_tag + inp_mult=inp_tag do k = top_lev, pver - call get_aer_num(numberConcentration(i,k,:), CloudnumberConcentration(i,k,:), rho(i,k), & + call get_aer_num(numberConcentration(i,k,:), CloudnumberConcentration(i,k,:), rho(i,k), & !++ MH_2015/04/10 f_acm(i,k,:), f_so4_condm(i,k,:), cam(i,k,:), volumeCore(i,k,:), volumeCoat(i,k,:), & !-- MH_2015/04/10 total_aer_num(i,k,:), coated_aer_num(i,k,:), uncoated_aer_num(i,k,:), & - total_interstitial_aer_num(i,k,:), total_cloudborne_aer_num(i,k,:), & - hetraer(i,k,:), awcam(i,k,:), awfacm(i,k,:), dstcoat(i,k,:), & + total_interstitial_aer_num(i,k,:), total_cloudborne_aer_num(i,k,:), & + hetraer(i,k,:), awcam(i,k,:), awfacm(i,k,:), dstcoat(i,k,:), & na500(i,k), tot_na500(i,k)) + ! jks set new variables here, could move out of the loop and just do once. + total_aer_num_scaled(i,k,:) = total_aer_num(i,k,:) * inp_mult + coated_aer_num_scaled(i,k,:) = coated_aer_num(i,k,:) * inp_mult + uncoated_aer_num_scaled(i,k,:) = uncoated_aer_num(i,k,:) * inp_mult + total_interstitial_aer_num_scaled(i,k,:) = total_interstitial_aer_num(i,k,:) *inp_mult + total_cloudborne_aer_num_scaled(i,k,:) = total_cloudborne_aer_num(i,k,:) * inp_mult + fn_cloudborne_aer_num(i,k,1) = total_aer_num(i,k,1)*factnum(i,k,MODE_IDX_OMBC_INTMIX_COAT_AIT) ! bc - fn_cloudborne_aer_num(i,k,2) = total_aer_num(i,k,2)*factnum(i,k,MODE_IDX_DST_A2) - fn_cloudborne_aer_num(i,k,3) = total_aer_num(i,k,3)*factnum(i,k,MODE_IDX_DST_A3) + fn_cloudborne_aer_num(i,k,2) = total_aer_num(i,k,2)*factnum(i,k,MODE_IDX_DST_A2) + fn_cloudborne_aer_num(i,k,3) = total_aer_num(i,k,3)*factnum(i,k,MODE_IDX_DST_A3) end do end do @@ -520,6 +559,11 @@ subroutine hetfrz_classnuc_oslo_calc( & call outfld('dst1_num', total_aer_num(:,:,2), pcols, lchnk) call outfld('dst3_num', total_aer_num(:,:,3), pcols, lchnk) + ! create variables so that the scaling can be checked 120919 + call outfld('bc_num_scaled', total_aer_num_scaled(:,:,1), pcols, lchnk) !jks + call outfld('dst1_num_scaled', total_aer_num_scaled(:,:,2), pcols, lchnk) !jks + call outfld('dst3_num_scaled', total_aer_num_scaled(:,:,3), pcols, lchnk) !jks + call outfld('bcc_num', coated_aer_num(:,:,1), pcols, lchnk) call outfld('dst1c_num', coated_aer_num(:,:,2), pcols, lchnk) call outfld('dst3c_num', coated_aer_num(:,:,3), pcols, lchnk) @@ -539,7 +583,7 @@ subroutine hetfrz_classnuc_oslo_calc( & call outfld('fn_bc_c1_num', fn_cloudborne_aer_num(:,:,1), pcols, lchnk) call outfld('fn_dst_c1_num', fn_cloudborne_aer_num(:,:,2), pcols, lchnk) call outfld('fn_dst_c3_num', fn_cloudborne_aer_num(:,:,3), pcols, lchnk) - + call outfld('na500', na500, pcols, lchnk) call outfld('totna500', tot_na500, pcols, lchnk) @@ -547,7 +591,7 @@ subroutine hetfrz_classnuc_oslo_calc( & call pbuf_get_field(pbuf, frzimm_idx, frzimm) call pbuf_get_field(pbuf, frzcnt_idx, frzcnt) call pbuf_get_field(pbuf, frzdep_idx, frzdep) - + frzimm(:ncol,:) = 0._r8 frzcnt(:ncol,:) = 0._r8 frzdep(:ncol,:) = 0._r8 @@ -585,6 +629,7 @@ subroutine hetfrz_classnuc_oslo_calc( & nidep_dst(:,:) = 0._r8 do i = 1, ncol + do k = top_lev, pver if (t(i,k) > 235.15_r8 .and. t(i,k) < 269.15_r8) then @@ -599,13 +644,14 @@ subroutine hetfrz_classnuc_oslo_calc( & fn(2) = factnum(i,k,MODE_IDX_DST_A2) ! dust_a1 accumulation mode fn(3) = factnum(i,k,MODE_IDX_DST_A3) ! dust_a3 coarse mode + ! jks. Setting the scaled aerosol numbers as arguments instead of the original call hetfrz_classnuc_calc( & deltatin, t(i,k), pmid(i,k), supersatice, & fn, r3lx, ncic*rho(i,k)*1.0e-6_r8, frzbcimm(i,k), frzduimm(i,k), & frzbccnt(i,k), frzducnt(i,k), frzbcdep(i,k), frzdudep(i,k), hetraer(i,k,:), & - awcam(i,k,:), awfacm(i,k,:), dstcoat(i,k,:), total_aer_num(i,k,:), & - coated_aer_num(i,k,:), uncoated_aer_num(i,k,:), total_interstitial_aer_num(i,k,:), & - total_cloudborne_aer_num(i,k,:), errstring) + awcam(i,k,:), awfacm(i,k,:), dstcoat(i,k,:), total_aer_num_scaled(i,k,:), & + coated_aer_num_scaled(i,k,:), uncoated_aer_num_scaled(i,k,:), total_interstitial_aer_num_scaled(i,k,:), & + total_cloudborne_aer_num_scaled(i,k,:), errstring) call handle_errmsg(errstring, subname="hetfrz_classnuc_calc") @@ -628,7 +674,7 @@ subroutine hetfrz_classnuc_oslo_calc( & nnudep_bc(i,k) = frzbcdep(i,k)*1.0e6_r8*ast(i,k) nnuccc_dst(i,k) = frzduimm(i,k)*1.0e6_r8*ast(i,k) - nnucct_dst(i,k) = frzducnt(i,k)*1.0e6_r8*ast(i,k) + nnucct_dst(i,k) = frzducnt(i,k)*1.0e6_r8*ast(i,k) nnudep_dst(i,k) = frzdudep(i,k)*1.0e6_r8*ast(i,k) niimm_bc(i,k) = frzbcimm(i,k)*1.0e6_r8*deltatin @@ -659,7 +705,7 @@ subroutine hetfrz_classnuc_oslo_calc( & call outfld('BCFREZDEP', nnudep_bc, pcols, lchnk) call outfld('NIMIX_IMM', niimm_bc+niimm_dst, pcols, lchnk) - call outfld('NIMIX_CNT', nicnt_bc+nicnt_dst, pcols, lchnk) + call outfld('NIMIX_CNT', nicnt_bc+nicnt_dst, pcols, lchnk) call outfld('NIMIX_DEP', nidep_bc+nidep_dst, pcols, lchnk) call outfld('DSTNICNT', nicnt_dst, pcols, lchnk) @@ -729,8 +775,9 @@ subroutine get_aer_num(qaerpt, qaercwpt, rhoair, & ! input total_interstial_aer_num, & total_cloudborne_aer_num, & hetraer, awcam, awfacm, dstcoat, & -!++ wy4.0 na500, tot_na500) + +!++ wy4.0 !-- wy4.0 use spmd_utils, only: iam @@ -757,13 +804,13 @@ subroutine get_aer_num(qaerpt, qaercwpt, rhoair, & ! input real(r8), intent(in) :: volumeCoat(nmodes_oslo) real(r8), intent(in) :: volumeCore(nmodes_oslo) real(r8) :: sigmag_amode(3) - - + + ! output real(r8), intent(out) :: total_aer_num(3) ! #/cm^3 real(r8), intent(out) :: total_interstial_aer_num(3) ! #/cm^3 real(r8), intent(out) :: total_cloudborne_aer_num(3) ! #/cm^3 - real(r8), intent(out) :: coated_aer_num(3) ! #/cm^3 + real(r8), intent(out) :: coated_aer_num(3) ! #/cm^3 real(r8), intent(out) :: uncoated_aer_num(3) ! #/cm^3 real(r8), intent(out) :: hetraer(3) ! BC and Dust mass mean radius [m] real(r8), intent(out) :: awcam(3) ! modal added mass [mug m-3] @@ -776,53 +823,53 @@ subroutine get_aer_num(qaerpt, qaercwpt, rhoair, & ! input real(r8), parameter :: n_so4_monolayers_dust = 1.0_r8 ! number of so4(+nh4) monolayers needed to coat a dust particle real(r8), parameter :: dr_so4_monolayers_dust = n_so4_monolayers_dust * 4.76e-10 real(r8) :: tmp1, tmp2 - + real(r8) :: bc_num ! bc number in accumulation mode real(r8) :: dst1_num, dst3_num ! dust number in accumulation and corase mode real(r8) :: dst1_num_imm, dst3_num_imm, bc_num_imm real(r8) :: fac_volsfc_bc, fac_volsfc_dust_a1, fac_volsfc_dust_a3 - - real(r8) :: r_bc ! model radii of BC modes [m] - real(r8) :: r_dust_a1, r_dust_a3 ! model radii of dust modes [m] - + + real(r8) :: r_bc ! model radii of BC modes [m] + real(r8) :: r_dust_a1, r_dust_a3 ! model radii of dust modes [m] + integer :: i - + integer :: num_bc_idx, num_dst1_idx, num_dst3_idx ! mode indices - + num_bc_idx = MODE_IDX_OMBC_INTMIX_COAT_AIT num_dst1_idx = MODE_IDX_DST_A2 num_dst3_idx = MODE_IDX_DST_A3 !***************************************************************************** -! calculate intersitial aerosol +! calculate intersitial aerosol !***************************************************************************** dst1_num = qaerpt(num_dst1_idx)*1.0e-6_r8 ! #/cm3 dst3_num = qaerpt(num_dst3_idx)*1.0e-6_r8 ! #/cm3 bc_num = qaerpt(num_bc_idx)*1.0e-6_r8 ! #/cm3 - + !***************************************************************************** -! calculate cloud borne aerosol +! calculate cloud borne aerosol !***************************************************************************** dst1_num_imm = qaercwpt(num_dst1_idx)*1.0e-6_r8 ! #/cm3 dst3_num_imm = qaercwpt(num_dst3_idx)*1.0e-6_r8 ! #/cm3 bc_num_imm = qaercwpt(num_bc_idx)*1.0e-6_r8 ! #/cm3 - + ! calculate mass mean radius r_dust_a1 = lifeCycleNumberMedianRadius(num_dst1_idx) r_dust_a3 = lifeCycleNumberMedianRadius(num_dst3_idx) r_bc = lifeCycleNumberMedianRadius(num_bc_idx) - + hetraer(1) = r_bc hetraer(2) = r_dust_a1 hetraer(3) = r_dust_a3 !***************************************************************************** -! calculate coated fraction +! calculate coated fraction !***************************************************************************** ! volumeCore and volumeCoat from subroutine calculateHygroscopicity in paramix_progncdnc.f90 @@ -842,25 +889,25 @@ subroutine get_aer_num(qaerpt, qaercwpt, rhoair, & ! input tmp1 = volumeCoat(num_dst1_idx)*(r_dust_a1*2._r8)*fac_volsfc_dust_a1 tmp2 = max(6.0_r8*dr_so4_monolayers_dust*volumeCore(num_dst1_idx), 0.0_r8) ! dr_so4_monolayers_dust = n_so4_monolayers_dust (=1) * 4.67e-10 dstcoat(2) = tmp1/tmp2 - + tmp1 = volumeCoat(num_dst3_idx)*(r_dust_a3*2._r8)*fac_volsfc_dust_a3 tmp2 = max(6.0_r8*dr_so4_monolayers_dust*volumeCore(num_dst3_idx), 0.0_r8) ! dr_so4_monolayers_dust = n_so4_monolayers_dust (=1) * 4.67e-10 dstcoat(3) = tmp1/tmp2 - + if (dstcoat(1) > 1._r8) dstcoat(1) = 1._r8 if (dstcoat(1) < 0.001_r8) dstcoat(1) = 0.001_r8 if (dstcoat(2) > 1._r8) dstcoat(2) = 1._r8 if (dstcoat(2) < 0.001_r8) dstcoat(2) = 0.001_r8 if (dstcoat(3) > 1._r8) dstcoat(3) = 1._r8 if (dstcoat(3) < 0.001_r8) dstcoat(3) = 0.001_r8 - + !***************************************************************************** -! prepare some variables for water activity +! prepare some variables for water activity !***************************************************************************** ! cam ([kg/m3] added mass distributed to modes) from paramix_progncdnc.f90 - - ! accumulation mode for dust_a1 - if (qaerpt(num_dst1_idx) > 0._r8) then + + ! accumulation mode for dust_a1 + if (qaerpt(num_dst1_idx) > 0._r8) then awcam(2) = cam(num_dst1_idx)*1.e9_r8 ! kg/m3 -> ug/m3 else awcam(2) = 0._r8 @@ -870,28 +917,28 @@ subroutine get_aer_num(qaerpt, qaercwpt, rhoair, & ! input else awfacm(2) = 0._r8 end if - + ! accumulation mode for dust_a3 - if (qaerpt(num_dst3_idx) > 0._r8) then + if (qaerpt(num_dst3_idx) > 0._r8) then awcam(3) = cam(num_dst3_idx)*1.e9_r8 ! kg/m3 -> ug/m3 else awcam(3) = 0._r8 end if if (awcam(3) >0._r8) then awfacm(3) = f_acm(num_dst3_idx) - else + else awfacm(3) = 0._r8 end if - - + + ! accumulation mode for bc - if (qaerpt(num_bc_idx) > 0._r8) then + if (qaerpt(num_bc_idx) > 0._r8) then awcam(1) = cam(num_bc_idx)*1.e9_r8 ! kg/m3 -> ug/m3 else awcam(1) = 0._r8 end if if (awcam(1) >0._r8) then - awfacm(1) = f_acm(num_bc_idx) + awfacm(1) = f_acm(num_bc_idx) else awfacm(1) = 0._r8 end if @@ -901,14 +948,14 @@ subroutine get_aer_num(qaerpt, qaercwpt, rhoair, & ! input ! prepare output !***************************************************************************** - total_interstial_aer_num(1) = bc_num - total_interstial_aer_num(2) = dst1_num - total_interstial_aer_num(3) = dst3_num + total_interstial_aer_num(1) = bc_num + total_interstial_aer_num(2) = dst1_num + total_interstial_aer_num(3) = dst3_num - total_cloudborne_aer_num(1) = bc_num_imm - total_cloudborne_aer_num(2) = dst1_num_imm + total_cloudborne_aer_num(1) = bc_num_imm + total_cloudborne_aer_num(2) = dst1_num_imm total_cloudborne_aer_num(3) = dst3_num_imm - + do i = 1, 3 total_aer_num(i) = total_interstial_aer_num(i)+total_cloudborne_aer_num(i) coated_aer_num(i) = total_interstial_aer_num(i)*dstcoat(i) @@ -937,7 +984,7 @@ subroutine get_aer_num(qaerpt, qaercwpt, rhoair, & ! input !#endif !-- wy4.0 - + end subroutine get_aer_num !==================================================================================================== diff --git a/src/chemistry/oslo_aero/koagsub.F90 b/src/chemistry/oslo_aero/koagsub.F90 index a183a4647e..3c095f5e73 100644 --- a/src/chemistry/oslo_aero/koagsub.F90 +++ b/src/chemistry/oslo_aero/koagsub.F90 @@ -32,23 +32,23 @@ module koagsub !aktest- !These are the modes which are coagulating (belonging to mixtures no. 0, 1, 2, 4, 12, 14) - integer, dimension(numberOfCoagulatingModes) :: coagulatingMode = & + integer, dimension(numberOfCoagulatingModes) :: coagulatingMode = & (/MODE_IDX_BC_EXT_AC & !inert mode , MODE_IDX_SO4SOA_AIT, MODE_IDX_BC_AIT, MODE_IDX_OMBC_INTMIX_COAT_AIT & !internally mixed small modes , MODE_IDX_BC_NUC, MODE_IDX_OMBC_INTMIX_AIT /) !externally mixed small modes - !These are the modes which are receiving coagulating material in OsloAero + !These are the modes which are receiving coagulating material in OsloAero ! (belonging to mixtures no. 5, 6, 7, 8, 9, 10) - integer, dimension(numberOfCoagulationReceivers) :: receiverMode = & + integer, dimension(numberOfCoagulationReceivers) :: receiverMode = & (/MODE_IDX_SO4_AC,MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SS_A1, MODE_IDX_SS_A2, MODE_IDX_SS_A3 /) !aktest+ !And these are the additional modes which are allowed to contribute to the - ! coagulation sink, defined here and to be used only in the nucleation code in condtend.F90 + ! coagulation sink, defined here and to be used only in the nucleation code in condtend.F90 ! (belonging to mixtures no. 0, 1, 2, 4, 12, 14) - integer, dimension(numberOfAddCoagReceivers) :: addReceiverMode = & + integer, dimension(numberOfAddCoagReceivers) :: addReceiverMode = & (/MODE_IDX_BC_EXT_AC,MODE_IDX_SO4SOA_AIT,MODE_IDX_BC_AIT, & - MODE_IDX_OMBC_INTMIX_COAT_AIT,MODE_IDX_BC_NUC,MODE_IDX_OMBC_INTMIX_AIT /) + MODE_IDX_OMBC_INTMIX_COAT_AIT,MODE_IDX_BC_NUC,MODE_IDX_OMBC_INTMIX_AIT /) !aktest- !Coagulation moves aerosol mass to the "coagulate" species, so some @@ -58,13 +58,13 @@ module koagsub ! Coagulation between aerosol and cloud droplets move coagulate into ! the equivalent value for aerosol concentration in cloud water. ! Exception: Sulphate coagulation with cloud droplets is merged with - ! component from aqueous phase chemistry in order to take advantage of the + ! component from aqueous phase chemistry in order to take advantage of the ! more detailed addition onto larger particles. integer, dimension(gas_pcnst) :: CloudAerReceiver ! Closest Table index for assumed size of droplets used in coagulation - integer :: tableindexcloud + integer :: tableindexcloud real(r8),parameter :: rcoagdroplet = 10.e-6 ! m @@ -168,7 +168,7 @@ subroutine initializeCoagulationCoefficients(rhob,rk) real(r8), intent(in) :: rk(0:nmodes) ![unit] radius of background (receiver) mode real(r8), intent(in) :: rhob(0:nmodes) !density of background mode - + real(r8), dimension(numberOfCoagulationReceivers, numberOfCoagulatingModes, nBinsTab) :: K12 = 0.0_r8 !Coagulation coefficient (m3/s) !nuctst3+ @@ -193,15 +193,15 @@ subroutine initializeCoagulationCoefficients(rhob,rk) do iCoagulatingMode = 1,numberOfCoagulatingModes !Index of the coagulating mode (0-14), see list above - modeIndexCoagulator = coagulatingMode(iCoagulatingMode) + modeIndexCoagulator = coagulatingMode(iCoagulatingMode) !Index of receiver mode (0-14), see list above - modeIndexReceiver = receiverMode(iReceiverMode) - + modeIndexReceiver = receiverMode(iReceiverMode) + !Pre-calculate coagulation coefficients for this coagulator.. - !Note: Not using actual density of coagulator here + !Note: Not using actual density of coagulator here !Since this is not known at init-time - call calculateCoagulationCoefficient(CoagulationCoefficient & !O [m3/s] coagulation coefficient + call calculateCoagulationCoefficient(CoagulationCoefficient & !O [m3/s] coagulation coefficient , rk(modeIndexCoagulator) & !I [m] radius of coagulator , rhob(modeIndexCoagulator) & !I [kg/m3] density of coagulator , rhob(modeIndexReceiver) ) !I [kg/m3] density of receiver @@ -213,7 +213,7 @@ subroutine initializeCoagulationCoefficients(rhob,rk) end do !receiver modes !nuctst3+ -! call calculateCoagulationCoefficient(CoagulationCoefficient & !O [m3/s] coagulation coefficient +! call calculateCoagulationCoefficient(CoagulationCoefficient & !O [m3/s] coagulation coefficient ! , rk(1) & !I [m] radius of coagulator ! , rhob(1) & !I [kg/m3] density of coagulator ! , rhob(1) ) !I [kg/m3] density of receiver @@ -224,15 +224,15 @@ subroutine initializeCoagulationCoefficients(rhob,rk) iCoagulatingMode = 1 !Index of the coagulating mode (0-14), see list above - modeIndexCoagulator = coagulatingMode(iCoagulatingMode) + modeIndexCoagulator = coagulatingMode(iCoagulatingMode) !Index of receiver mode (0-14), see list above - modeIndexReceiver = addReceiverMode(iReceiverMode) - + modeIndexReceiver = addReceiverMode(iReceiverMode) + !Pre-calculate coagulation coefficients for this coagulator.. - !Note: Not using actual density of coagulator here + !Note: Not using actual density of coagulator here !Since this is not known at init-time - call calculateCoagulationCoefficient(CoagulationCoefficient & !O [m3/s] coagulation coefficient + call calculateCoagulationCoefficient(CoagulationCoefficient & !O [m3/s] coagulation coefficient , rk(modeIndexCoagulator) & !I [m] radius of coagulator , rhob(modeIndexCoagulator) & !I [kg/m3] density of coagulator , rhob(modeIndexReceiver) ) !I [kg/m3] density of receiver @@ -247,12 +247,12 @@ subroutine initializeCoagulationCoefficients(rhob,rk) do iCoagulatingMode = 1,numberOfCoagulatingModes !Index of the coagulating mode (0-14), see list above - modeIndexCoagulator = coagulatingMode(iCoagulatingMode) - + modeIndexCoagulator = coagulatingMode(iCoagulatingMode) + !Pre-calculate coagulation coefficients for this coagulator.. - !Note: Not using actual density of coagulator here + !Note: Not using actual density of coagulator here !Since this is not known at init-time - call calculateCoagulationCoefficient(CoagulationCoefficient & !O [m3/s] coagulation coefficient + call calculateCoagulationCoefficient(CoagulationCoefficient & !O [m3/s] coagulation coefficient , rk(modeIndexCoagulator) & !I [m] radius of coagulator , rhob(modeIndexCoagulator) & !I [kg/m3] density of coagulator , rhoh2o ) !I [kg/m3] density of receiver @@ -277,9 +277,9 @@ subroutine initializeCoagulationCoefficients(rhob,rk) modeIndexCoagulator = coagulatingMode(iCoagulatingMode) !Index of the coagulating mode modeIndexReceiver = receiverMode(iReceiverMode) !Index of receiver mode - - do nsiz=1,nBinsTab !aerotab bin sizes - + + do nsiz=1,nBinsTab !aerotab bin sizes + !Sum up coagulation sink for this coagulating species (for all receiving modes) normalizedCoagulationSink(modeIndexReceiver, modeIndexCoagulator) = & ![m3/#/s] normalizedCoagulationSink(modeIndexReceiver, modeIndexCoagulator) & ![m3/#/s] Previous value @@ -288,13 +288,13 @@ subroutine initializeCoagulationCoefficients(rhob,rk) end do !Look up table size end do !receiver modes end do !coagulator - + !nuctst3+ ! !Add simple self coagulation sink for mode 1 (with 1) in such a way that it ! !affects coagulationSink but not the lifecycling (directly) otherwise ! normCoagSinkMode1 = 0.0_r8 -! do nsiz=1,nBinsTab !aerotab bin sizes +! do nsiz=1,nBinsTab !aerotab bin sizes ! normCoagSinkMode1 = normCoagSinkMode1 + normnk(1,nsiz) * CoagCoeffMode1(nsiz) ! end do !Look up table size !nuctst3- @@ -308,9 +308,9 @@ subroutine initializeCoagulationCoefficients(rhob,rk) do iReceiverMode = 1, numberOfAddCoagReceivers modeIndexReceiver = addReceiverMode(iReceiverMode) !Index of additional receiver mode - - do nsiz=1,nBinsTab !aerotab bin sizes - + + do nsiz=1,nBinsTab !aerotab bin sizes + !Sum up coagulation sink for this coagulating species (for all receiving modes) normCoagSinkAdd(iReceiverMode) = & ![m3/#/s] normCoagSinkAdd(iReceiverMode) & ![m3/#/s] Previous value @@ -319,17 +319,17 @@ subroutine initializeCoagulationCoefficients(rhob,rk) end do !Look up table size end do !receiver modes !ak- - + nsiz=1 do while (rBinMidPoint(nsiz).lt.rcoagdroplet.and.nsiz.lt.nBinsTab) nsiz=nsiz+1 end do - if (abs(rBinMidPoint(nsiz-1)-rcoagdroplet).lt.abs(rBinMidPoint(nsiz)-rcoagdroplet)) then + if (abs(rBinMidPoint(nsiz-1)-rcoagdroplet).lt.abs(rBinMidPoint(nsiz)-rcoagdroplet)) then tableindexcloud=nsiz-1 else tableindexcloud=nsiz - end if + end if write(iulog,*) 'Assumed droplet size and table bin number for cloud & coagulation ',rcoagdroplet, ' nbin ',tableindexcloud,'binmid',rBinMidPoint(tableindexcloud) @@ -338,9 +338,9 @@ subroutine initializeCoagulationCoefficients(rhob,rk) NCloudCoagulationSink(modeIndexCoagulator) = & ![m3/#/s] K12Cl(iCoagulatingMode, tableindexcloud) !Koagulation coefficient (m3/#/s) - + end do - + end subroutine initializeCoagulationCoefficients !Calculates coagulation coefficient for a coagulator mode @@ -362,7 +362,7 @@ subroutine calculateCoagulationCoefficient(CoagulationCoefficient, modeRadius, m real(r8) :: g1 ![-] factor real(r8) :: g2 ![-] factor real(r8) :: c12 ![m/s] average particle thermal velocity - real(r8) :: c1 ![m/s] particle thermal velocity + real(r8) :: c1 ![m/s] particle thermal velocity real(r8) :: c2 ![m/s] particle thermal velocity real(r8) :: mfv1 ![m] mean free path particle real(r8) :: mfv2 ![m] mean free path particle @@ -402,10 +402,10 @@ end subroutine calculateCoagulationCoefficient !Time step routine for coagulation !Called from chemistry -subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) +subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) -! Calculate the coagulation of small aerosols with larger particles and -! cloud droplets. Only particles smaller that dry radius of +! Calculate the coagulation of small aerosols with larger particles and +! cloud droplets. Only particles smaller that dry radius of ! 40 nm is assumed to have an efficient coagulation with other particles. use shr_kind_mod, only: r8 => shr_kind_r8 @@ -416,7 +416,7 @@ subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) use physics_buffer, only : physics_buffer_desc use modal_aero_data, only : qqcw_get_field implicit none - + ! input arguments integer, intent(in) :: ncol ! number of horizontal grid cells (columns) @@ -439,7 +439,7 @@ subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) integer :: modeIndexCoagulator !Index of coagulating mode integer :: modeIndexReceiver !Index of receiving mode real(r8) :: rhoAir ![kg/m3] air density - real(r8) :: coagulationSink ![1/s] loss for coagulating specie + real(r8) :: coagulationSink ![1/s] loss for coagulating specie real(r8), dimension(numberOfCoagulationReceivers):: numberConcentration ![#/m3] number concentration real(r8) :: totalLoss(pcols,pver,gas_pcnst) ![kg/kg] tracer lost character(128) :: long_name ![-] needed for diagnostics @@ -455,11 +455,11 @@ subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) call phys_getopts(history_aerosol_out = history_aerosol) do k=1,pver - do i=1,ncol - + do i=1,ncol + !Air density rhoAir = pmid(i,k)/rair/temperature(i,k) - + !Initialize number concentration for all receivers numberConcentration(:) = 0.0_r8 @@ -480,7 +480,7 @@ subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) numberConcentration(iReceiver) = numberConcentration(iReceiver) & !previous value + q(i,k,l_index_receiver) & !kg/kg / rhopart(physicsIndex(l_index_receiver)) & !*[m3/kg] ==> m3/kg - * volumeToNumber(receiverMode(ireceiver)) & ![#/m3] ==> #/kg + * volumeToNumber(receiverMode(ireceiver)) & ![#/m3] ==> #/kg * rhoAir !#/kg ==> #/m3 end if end do !Lifecycle "core" species in this mode @@ -497,16 +497,16 @@ subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) !Sum the loss for all possible receivers do iReceiver = 1, numberOfCoagulationReceivers - + modeIndexReceiver = receiverMode(iReceiver) !Sum up coagulation sink for this coagulating species (for all receiving modes) coagulationSink = & ![1/s] coagulationSink + & ![1/] previous value - normalizedCoagulationSink(modeIndexReceiver, modeIndexCoagulator) & ![m3/#/s] + normalizedCoagulationSink(modeIndexReceiver, modeIndexCoagulator) & ![m3/#/s] * numberConcentration(ireceiver) !numberConcentration (#/m3) end do !receiver modes - + !SOME LIFECYCLE SPECIES CHANGE "HOST MODE" WHEN THEY PARTICIPATE !IN COAGULATION (THEY GO FROM EXTERNALLY MIXED TO INTERNALLY MIXED MODES) @@ -520,8 +520,8 @@ subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) !process modes don't change mode except so4 condensate which becomes coagulate instead !assumed to have same sink as MODE_IDX_OMBC_INTMIX_AIT - if( .NOT. is_process_mode(l_index_donor,.true.) & - .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. modeIndexCoagulator .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then + if( .NOT. is_process_mode(l_index_donor,.true.) & + .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. modeIndexCoagulator .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then !Done summing total loss of this coagulating specie totalLoss(i,k,l_index_donor) = coagulationSink & !loss rate for a mode in [1/s] summed over all receivers @@ -548,12 +548,12 @@ subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) !so4_a1 is a process mode (condensate), but is still lost in coagulation if( .NOT. is_process_mode(l_index_donor, .true.) & - .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. coagulatingMode(iCoagulator) .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then + .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. coagulatingMode(iCoagulator) .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then l_index_donor = getTracerIndex(coagulatingMode(iCoagulator) , ispecie,.true. ) !index of mode gaining mass (l_so4_ac, l_om_ac, l_bc_ac), coagulate - l_index_receiver = lifeCycleReceiver(l_index_donor) + l_index_receiver = lifeCycleReceiver(l_index_donor) do k=1,pver !Loose mass from tracer in donor mode @@ -569,13 +569,13 @@ subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) !Output for diagnostics if(history_aerosol)then coltend(:ncol,:) = 0.0_r8 - do i=1,gas_pcnst + do i=1,gas_pcnst !Check if species contributes to coagulation if(lifeCycleReceiver(i) .gt. 0)then !Loss from the donor specie tracer_coltend(:ncol) = sum(totalLoss(:ncol, :,i)*pdel(:ncol,:),2)/gravit*delt_inverse coltend(:ncol,i) = coltend(:ncol,i) - tracer_coltend(:ncol) !negative, loss for donor - coltend(:ncol,lifeCycleReceiver(i)) = coltend(:ncol,lifeCycleReceiver(i)) + tracer_coltend(:ncol) + coltend(:ncol,lifeCycleReceiver(i)) = coltend(:ncol,lifeCycleReceiver(i)) + tracer_coltend(:ncol) endif end do do i=1,gas_pcnst @@ -590,10 +590,10 @@ subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) end subroutine coagtend -subroutine clcoag( q, pmid, pdel, temperature, cldnum, cldfrc, delt_inverse, ncol , lchnk, im, pbuf) +subroutine clcoag( q, pmid, pdel, temperature, cldnum, cldfrc, delt_inverse, ncol , lchnk, im, pbuf) -! Calculate the coagulation of small aerosols with larger particles and -! cloud droplets. Only particles smaller that dry radius of +! Calculate the coagulation of small aerosols with larger particles and +! cloud droplets. Only particles smaller that dry radius of ! 40 nm is assumed to have an efficient coagulation with other particles. use shr_kind_mod, only: r8 => shr_kind_r8 @@ -604,17 +604,17 @@ subroutine clcoag( q, pmid, pdel, temperature, cldnum, cldfrc, delt_inverse, nc use physics_buffer, only : physics_buffer_desc use modal_aero_data, only : qqcw_get_field implicit none - + ! input arguments integer, intent(in) :: ncol ! number of horizontal grid cells (columns) - real(r8), intent(inout) :: q(pcols,pver,gas_pcnst) ! TMR [kg/kg] including moisture - real(r8), intent(in) :: pmid(pcols,pver) ! [Pa] midpoint pressure - real(r8), intent(in) :: pdel(pcols,pver) - real(r8), intent(in) :: temperature(pcols,pver) ! [K] temperature + real(r8), intent(inout) :: q(:,:,:) ! TMR [kg/kg] including moisture + real(r8), intent(in) :: pmid(:,:) ! [Pa] midpoint pressure + real(r8), intent(in) :: pdel(:,:) + real(r8), intent(in) :: temperature(:,:) ! [K] temperature - real(r8), dimension(ncol,pver),intent(in) :: cldnum ! Droplet concentration #/kg - real(r8), dimension(ncol,pver),intent(in) :: cldfrc ! Cloud volume fraction + real(r8), dimension(:,:),intent(in) :: cldnum ! Droplet concentration #/kg + real(r8), dimension(:,:),intent(in) :: cldfrc ! Cloud volume fraction real(r8), intent(in) :: delt_inverse ! [1/s] inverse time step integer, intent(in) :: lchnk ! [] chnk id needed for output @@ -635,7 +635,7 @@ subroutine clcoag( q, pmid, pdel, temperature, cldnum, cldfrc, delt_inverse, nc integer :: l_index_donor integer :: modeIndexCoagulator !Index of coagulating mode integer :: modeIndexReceiver !Index of receiving mode - real(r8) :: coagulationSink ![1/s] loss for coagulating specie + real(r8) :: coagulationSink ![1/s] loss for coagulating specie real(r8), dimension(numberOfCoagulationReceivers):: numberConcentration ![#/m3] number concentration real(r8) :: cloudLoss(pcols,pver,gas_pcnst) ![kg/kg] tracer lost character(128) :: long_name ![-] needed for diagnostics @@ -652,7 +652,7 @@ subroutine clcoag( q, pmid, pdel, temperature, cldnum, cldfrc, delt_inverse, nc do k=1,pver - do i=1,ncol + do i=1,ncol if (cldfrc(i,k).gt.1.e-2) then rhoAir = pmid(i,k)/rair/temperature(i,k) !Go through all coagulating modes @@ -668,9 +668,9 @@ subroutine clcoag( q, pmid, pdel, temperature, cldnum, cldfrc, delt_inverse, nc !Sum up coagulation sink for this coagulating species (for all receiving modes) coagulationSink = & ![1/s] - NCloudCoagulationSink(modeIndexCoagulator) & ![m3/#/s] + NCloudCoagulationSink(modeIndexCoagulator) & ![m3/#/s] * (rhoair*cldnum(i,k)/cldfrc(i,k)) ![kg/m3*#/kg - + !Each coagulating mode can contain several species do ispecie = 1, getNumberOfTracersInMode(modeIndexCoagulator) @@ -681,24 +681,24 @@ subroutine clcoag( q, pmid, pdel, temperature, cldnum, cldfrc, delt_inverse, nc !process modes don't change mode except so4 condensate which becomes coagulate instead !assumed to have same sink as MODE_IDX_OMBC_INTMIX_AIT - if( .NOT. is_process_mode(l_index_donor,.true.) & - .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. modeIndexCoagulator .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then + if( .NOT. is_process_mode(l_index_donor,.true.) & + .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. modeIndexCoagulator .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then !Done summing total loss of this coagulating specie cloudLoss(i,k,l_index_donor) = coagulationSink & !loss rate for a mode in [1/s] summed over all receivers * cldfrc(i,k)*q(i,k,l_index_donor) & !* mixing ratio ==> MMR/s / delt_inverse ! seconds ==> MMR - !Can not loose more than we have + !Can not loose more than we have ! At present day assumed lost within the cloud cloudLoss(i,k,l_index_donor) = min(cloudLoss(i,k,l_index_donor) , cldfrc(i,k)*q(i,k,l_index_donor)) - + end if !check on process modes end do !species in mode - + end do !coagulator mode - end if ! cldfrc .gt. 0.01 + end if ! cldfrc .gt. 0.01 end do ! i end do ! k @@ -710,12 +710,12 @@ subroutine clcoag( q, pmid, pdel, temperature, cldnum, cldfrc, delt_inverse, nc !so4_a1 is a process mode (condensate), but is still lost in coagulation if( .NOT. is_process_mode(l_index_donor, .true.) & - .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. coagulatingMode(iCoagulator) .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then + .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. coagulatingMode(iCoagulator) .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then l_index_donor = getTracerIndex(coagulatingMode(iCoagulator) , ispecie,.true. ) !index of mode gaining mass (l_so4_a2, l_om_ac, l_bc_ac), coagulate - l_index_receiver = CloudAerReceiver(l_index_donor) + l_index_receiver = CloudAerReceiver(l_index_donor) fldcw => qqcw_get_field(pbuf, CloudAerReceiver(l_index_donor)+im,lchnk,errorhandle=.true.) do k=1,pver !Loose mass from tracer in donor mode @@ -723,24 +723,24 @@ subroutine clcoag( q, pmid, pdel, temperature, cldnum, cldfrc, delt_inverse, nc !Give mass to tracer in receiver mode if(associated(fldcw)) then fldcw(:ncol,k) = fldcw(:ncol,k) + cloudLoss(:ncol,k,l_index_donor) - end if + end if end do !k endif end do - end do + end do !Output for diagnostics if(history_aerosol)then coltend(:ncol,:) = 0.0_r8 - do i=1,gas_pcnst + do i=1,gas_pcnst !Check if species contributes to coagulation if(CloudAerReceiver(i) .gt. 0)then !Loss from the donor specie tracer_coltend(:ncol) = sum(cloudLoss(:ncol, :,i)*pdel(:ncol,:),2)/gravit*delt_inverse coltend(:ncol,i) = coltend(:ncol,i) - tracer_coltend(:ncol) !negative, loss for donor - coltend(:ncol,CloudAerReceiver(i)) = coltend(:ncol,CloudAerReceiver(i)) + tracer_coltend(:ncol) + coltend(:ncol,CloudAerReceiver(i)) = coltend(:ncol,CloudAerReceiver(i)) + tracer_coltend(:ncol) endif end do do i=1,gas_pcnst @@ -785,9 +785,9 @@ function calculateParticleDiffusivity(radius) result (diffusivity) knudsenNumber = mfpAir/radius - factor = (kboltzmann*temperatureLookupTables/3.0_r8/pi/viscosityAir/2.0_r8/radius) + factor = (kboltzmann*temperatureLookupTables/3.0_r8/pi/viscosityAir/2.0_r8/radius) numerator = 5.0_r8 + 4.0_r8*knudsenNumber + 6.0_r8*knudsenNumber**2 + 18.0_r8*knudsenNumber**3 - nominator = 5.0_r8 - knudsenNumber + (8.0_r8 + pi)*knudsenNumber**2 + nominator = 5.0_r8 - knudsenNumber + (8.0_r8 + pi)*knudsenNumber**2 diffusivity = factor*numerator/nominator end function calculateParticleDiffusivity diff --git a/src/chemistry/oslo_aero/module_random_forests.F90 b/src/chemistry/oslo_aero/module_random_forests.F90 new file mode 100644 index 0000000000..5757fb1a50 --- /dev/null +++ b/src/chemistry/oslo_aero/module_random_forests.F90 @@ -0,0 +1,452 @@ +!PG RaFSIP PARAMETERS + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!This MODULE holds the subroutines which are used to initialize all + +!built random forest regressors. + +!This MODULE CONTAINS the following routines: + +! *forestbrhm + +! *forestbr + +! *forestall + +! *forestbrds + +! *forestbrwarm + +!Each subroutine opens, reads and stores the parameters of all 4 + +!random forest regressors. The initial .txt files are first + +!converted into binary files so that the processing is faster. + +! + +!This module also includes the three subroutines that make all the + +!random forest predictions needed in the microphysics routine. + +!These are the following: + +! *runforest + +! *runforestriv + +! *runforestmulti + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + MODULE module_random_forests + + use micro_mg_utils, only: r8 + use spmd_utils, only: masterproc + use phys_control, only: use_simple_phys + use cam_abortutils, only: endrun + + IMPLICIT NONE + + PUBLIC :: sec_ice_readnl + + PUBLIC :: forestbrhm,forestbr,forestall,forestbrds,forestbrwarm,runforest,runforestriv,runforestmulti + + !!MDIM DEFINES THE NUMBER OF FEATURES/INPUTS TO THE RaFSIP PARAMETERIZATION + INTEGER, PARAMETER, PUBLIC :: MDIM5=5 + INTEGER, PARAMETER, PUBLIC :: MDIM6=6 + INTEGER, PARAMETER, PUBLIC :: JBT=10 !!The number of trees in each random forest regressor + + !!The maximum number of nodes across trees + INTEGER, PARAMETER, PUBLIC :: MAX_NODES1=7705 !forestBRHM + INTEGER, PARAMETER, PUBLIC :: MAX_NODES2=8219 !forestBR + INTEGER, PARAMETER, PUBLIC :: MAX_NODES3=7833 !forestALL + INTEGER, PARAMETER, PUBLIC :: MAX_NODES4=7093 !forestBRDS + INTEGER, PARAMETER, PUBLIC :: MAX_NODES5=8593 !forestBRwarm + + !!Thresh = threshold value at each internal node + !!Outi = prediction for a given node + REAL(r8), DIMENSION(JBT,MAX_NODES1), PUBLIC :: THRESH1,OUT11,OUT12,OUT13 + REAL(r8), DIMENSION(JBT,MAX_NODES2), PUBLIC :: THRESH2,OUT21 + REAL(r8), DIMENSION(JBT,MAX_NODES3), PUBLIC :: THRESH3,OUT31,OUT32,OUT33,OUT34,OUT35 + REAL(r8), DIMENSION(JBT,MAX_NODES4), PUBLIC :: THRESH4,OUT41,OUT42,OUT43 + REAL(r8), DIMENSION(JBT,MAX_NODES5), PUBLIC :: THRESH5,OUT51 + + !!Splitfeat = feature used for splitting the node + !!Leftchild = left child of node + !!Rightchild = right child of node + INTEGER, DIMENSION(JBT,MAX_NODES1), PUBLIC :: SPLITFEAT1,LEFTCHILD1,RIGHTCHILD1 + INTEGER, DIMENSION(JBT,MAX_NODES2), PUBLIC :: SPLITFEAT2,LEFTCHILD2,RIGHTCHILD2 + INTEGER, DIMENSION(JBT,MAX_NODES3), PUBLIC :: SPLITFEAT3,LEFTCHILD3,RIGHTCHILD3 + INTEGER, DIMENSION(JBT,MAX_NODES4), PUBLIC :: SPLITFEAT4,LEFTCHILD4,RIGHTCHILD4 + INTEGER, DIMENSION(JBT,MAX_NODES5), PUBLIC :: SPLITFEAT5,LEFTCHILD5,RIGHTCHILD5 + + !!The exact number of nodes across in consecutive trees of the forest + INTEGER, DIMENSION(JBT) :: NRNODES1,NRNODES2,NRNODES3,NRNODES4,NRNODES5 + + LOGICAL, PUBLIC :: FIRST_RAFSIP = .TRUE. + + character(len=256), public :: forestfileALL,forestfileBRDS + character(len=256), public :: forestfileBRHM,forestfileBR + character(len=256), public :: forestfileBRwarm + + CONTAINS + + +!--------------------------------------------------------------------------------------------------------------- + + + subroutine sec_ice_readnl(nlfile) + ! Read files needed for random forest tables of seconary ice formation + + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use mpishorthand + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + + ! Local variables + integer :: unitn, ierr, i + character(len=2) :: suffix + character(len=1), pointer :: ctype(:) + character(len=*), parameter :: subname = 'sec_ice_readnl' + + + namelist /sec_ice_nl/ forestfileALL, & + forestfileBRDS, & + forestfileBRHM, & + forestfileBR, & + forestfileBRwarm + + if (use_simple_phys) return + + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'sec_ice_nl', status=ierr) + if (ierr == 0) then + read(unitn, sec_ice_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + end if + +#ifdef SPMD + + call mpibcast (forestfileALL, len(forestfileALL), mpichar, 0, mpicom) + call mpibcast (forestfileBRDS, len(forestfileBRDS), mpichar, 0, mpicom) + call mpibcast (forestfileBRHM, len(forestfileBRHM), mpichar, 0, mpicom) + call mpibcast (forestfileBR, len(forestfileBR), mpichar, 0, mpicom) + call mpibcast (forestfileBRwarm,len(forestfileBRwarm), mpichar, 0, mpicom) + +#endif +end subroutine sec_ice_readnl + + SUBROUTINE forestbrhm(jbt,max_nodes1,leftchild1,rightchild1,splitfeat1, & + nrnodes1,thresh1,out11,out12,out13) + use units, only: getunit, freeunit + IMPLICIT NONE + + INTEGER,intent(in) :: jbt, max_nodes1 + + REAL (r8),DIMENSION(jbt,max_nodes1),intent(inout) :: thresh1,out11,out12,out13 + INTEGER,DIMENSION(jbt,max_nodes1),intent(inout) :: splitfeat1,leftchild1,rightchild1 + INTEGER,DIMENSION(jbt),intent(inout) :: nrnodes1 + + INTEGER :: jb,n + + integer :: unitn, ierr, i +! unitn = 137 + open( 137, file=trim(forestfileBRHM), form='formatted',status='old' ) + !Open the ASCII file +! OPEN(unit=137,file="forestBRHM.txt",status="old",action="read") +! OPEN(unit=137,file=forestfileBRHM,status="old",action="read") + DO jb=1,jbt + read (137,*) nrnodes1(jb) + read (137,*) (leftchild1(jb,n),rightchild1(jb,n),out11(jb,n),out12(jb,n),out13(jb,n), & + & thresh1(jb,n),splitfeat1(jb,n), n=1,nrnodes1(jb)) + ENDDO + CLOSE(137) +! call freeunit(unitn) + + END subroutine forestbrhm +!--------------------------------------------------------------------------------------------------------------- + + +!--------------------------------------------------------------------------------------------------------------- + SUBROUTINE forestbr(jbt,max_nodes2,leftchild2,rightchild2,splitfeat2, & + nrnodes2,thresh2,out21) + + IMPLICIT NONE + + INTEGER,intent(in) :: jbt, max_nodes2 + + REAL(r8),DIMENSION(jbt,max_nodes2),intent(inout) :: thresh2,out21 + INTEGER,DIMENSION(jbt,max_nodes2),intent(inout) :: splitfeat2,leftchild2,rightchild2 + INTEGER,DIMENSION(jbt),intent(inout) :: nrnodes2 + + INTEGER :: jb,n + +! OPEN(unit=138,file="forestBR.txt",status="old",action="read") + OPEN(unit=138,file=forestfileBR,status="old",action="read") + DO jb=1,jbt + read (138,*) nrnodes2(jb) + read (138,*) (leftchild2(jb,n),rightchild2(jb,n),out21(jb,n), & + & thresh2(jb,n),splitfeat2(jb,n), n=1,nrnodes2(jb)) + ENDDO + CLOSE(138) + + END subroutine forestbr +!--------------------------------------------------------------------------------------------------------------- + + +!--------------------------------------------------------------------------------------------------------------- + SUBROUTINE forestall(jbt,max_nodes3,leftchild3,rightchild3,splitfeat3, & + nrnodes3,thresh3,out31,out32,out33,out34,out35) + + IMPLICIT NONE + + INTEGER,intent(in) :: jbt, max_nodes3 + + REAL(r8),DIMENSION(jbt,max_nodes3),intent(inout) :: thresh3,out31,out32,out33,out34,out35 + INTEGER,DIMENSION(jbt,max_nodes3),intent(inout) :: splitfeat3,leftchild3,rightchild3 + INTEGER,DIMENSION(jbt),intent(inout) :: nrnodes3 + + INTEGER :: jb,n + +! OPEN(unit=139,file="forestALL.txt",status="old",action="read") + OPEN(unit=139,file=forestfileALL,status="old",action="read") + DO jb=1,jbt + read (139,*) nrnodes3(jb) + read (139,*) (leftchild3(jb,n),rightchild3(jb,n),out31(jb,n),out32(jb,n),out33(jb,n), & + & out34(jb,n),out35(jb,n),thresh3(jb,n),splitfeat3(jb,n), n=1,nrnodes3(jb)) + ENDDO + CLOSE(139) + + END subroutine forestall +!--------------------------------------------------------------------------------------------------------------- + + + +!--------------------------------------------------------------------------------------------------------------- + SUBROUTINE forestbrds(jbt,max_nodes4,leftchild4,rightchild4,splitfeat4, & + nrnodes4,thresh4,out41,out42,out43) + + IMPLICIT NONE + + INTEGER,intent(in) :: jbt, max_nodes4 + + REAL(r8),DIMENSION(jbt,max_nodes4),intent(inout) :: thresh4,out41,out42,out43 + INTEGER,DIMENSION(jbt,max_nodes4),intent(inout) :: splitfeat4,leftchild4,rightchild4 + INTEGER,DIMENSION(jbt),intent(inout) :: nrnodes4 + + INTEGER :: jb,n + +! OPEN(unit=140,file="forestBRDS.txt",status="old",action="read") + OPEN(unit=140,file=forestfileBRDS,status="old",action="read") + DO jb=1,jbt + read (140,*) nrnodes4(jb) + read (140,*) (leftchild4(jb,n),rightchild4(jb,n),out41(jb,n),out42(jb,n),out43(jb,n), & + & thresh4(jb,n),splitfeat4(jb,n), n=1,nrnodes4(jb)) + ENDDO + CLOSE(140) + + END subroutine forestbrds +!--------------------------------------------------------------------------------------------------------------- + + +!--------------------------------------------------------------------------------------------------------------- + SUBROUTINE forestbrwarm(jbt,max_nodes5,leftchild5,rightchild5,splitfeat5, & + nrnodes5,thresh5,out51) + + IMPLICIT NONE + + INTEGER,intent(in) :: jbt, max_nodes5 + + REAL(r8),DIMENSION(jbt,max_nodes5),intent(inout) :: thresh5,out51 + INTEGER,DIMENSION(jbt,max_nodes5),intent(inout) :: splitfeat5,leftchild5,rightchild5 + INTEGER,DIMENSION(jbt),intent(inout) :: nrnodes5 + + INTEGER :: jb,n + +! OPEN(unit=141,file="forestBRwarm.txt",status="old",action="read") + OPEN(unit=141,file=forestfileBRwarm,status="old",action="read") + DO jb=1,jbt + read (141,*) nrnodes5(jb) + read (141,*) (leftchild5(jb,n),rightchild5(jb,n),out51(jb,n), & + & thresh5(jb,n),splitfeat5(jb,n), n=1,nrnodes5(jb)) + ENDDO + CLOSE(141) + + END subroutine forestbrwarm +!--------------------------------------------------------------------------------------------------------------- + + + +!======================================================================+ +! THREE SUBROUTINES CALLED BY THE RaFSIP PARAMETERIZATION ! +!======================================================================+ + + !This subroutine is called only when the requirements for the + !activation of the forestBR model are met (i.e., -25 shr_kind_r8 @@ -539,7 +539,7 @@ subroutine coagtend_sec( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk use commondefinitions, only: originalnumbermedianradius !smb--sectional implicit none - + ! input arguments integer, intent(in) :: ncol ! number of horizontal grid cells (columns) @@ -565,7 +565,7 @@ subroutine coagtend_sec( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk integer :: modeIndexCoagulator !Index of coagulating mode integer :: modeIndexReceiver !Index of receiving mode real(r8) :: rhoAir ![kg/m3] air density - real(r8) :: coagulationSink ![1/s] loss for coagulating specie + real(r8) :: coagulationSink ![1/s] loss for coagulating specie real(r8), dimension(numberOfCoagulationReceivers+numberOfCoagulatingModes):: numberConcentration ![#/m3] number concentration real(r8), dimension(secNrBins):: numberConcentration_sec ![#/m3] number concentration total smb real(r8), dimension(secNrSpec, secNrBins) :: numberConcentration_sec_all ![#/m3] number concentration not total smb @@ -586,11 +586,11 @@ subroutine coagtend_sec( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk call phys_getopts(history_aerosol_out = history_aerosol) do k=1,pver - do i=1,ncol - + do i=1,ncol + !Air density rhoAir = pmid(i,k)/rair/temperature(i,k) - + !Initialize number concentration for all receivers numberConcentration(:) = 0.0_r8 @@ -611,7 +611,7 @@ subroutine coagtend_sec( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk numberConcentration(iReceiver) = numberConcentration(iReceiver) & !previous value + q(i,k,l_index_receiver) & !kg/kg / rhopart(physicsIndex(l_index_receiver)) & !*[m3/kg] ==> m3/kg - * volumeToNumber(receiverModeNPF(ireceiver)) & ![#/m3] ==> #/kg + * volumeToNumber(receiverModeNPF(ireceiver)) & ![#/m3] ==> #/kg * rhoAir !#/kg ==> #/m3 end if @@ -733,7 +733,7 @@ subroutine coagtend_sec( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk l_index_donor = chemistryIndex( secConstIndex(ispecie, iCoagulator))!l_soa_na !getTracerIndex(coagulatingMode(iCoagulator) , ispecie,.true. ) !index of mode gaining mass (l_so4_ac, l_om_ac, l_bc_ac), coagulate - l_index_receiver = chemistryIndex(seccoagulate_receiver(ispecie)) !lifeCycleReceiver(l_index_donor) + l_index_receiver = chemistryIndex(seccoagulate_receiver(ispecie)) !lifeCycleReceiver(l_index_donor) do k=1,pver !Loose mass from tracer in donor bin @@ -757,17 +757,17 @@ subroutine coagtend_sec( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk end do ! iCoagulator endif !smb--sectional - + !Output for diagnostics if(history_aerosol)then coltend(:ncol,:) = 0.0_r8 - do i=1,gas_pcnst + do i=1,gas_pcnst !Check if species contributes to coagulation if(lifeCycleReceiver(i) .gt. 0)then !Loss from the donor specie tracer_coltend(:ncol) = sum(totalLoss(:ncol, :,i)*pdel(:ncol,:),2)/gravit*delt_inverse coltend(:ncol,i) = coltend(:ncol,i) - tracer_coltend(:ncol) !negative, loss for donor - coltend(:ncol,lifeCycleReceiver(i)) = coltend(:ncol,lifeCycleReceiver(i)) + tracer_coltend(:ncol) + coltend(:ncol,lifeCycleReceiver(i)) = coltend(:ncol,lifeCycleReceiver(i)) + tracer_coltend(:ncol) endif end do do i=1,gas_pcnst @@ -780,7 +780,7 @@ subroutine coagtend_sec( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk end if end do endif - + !smb++sectional call aerosect_write2file(q,lchnk,ncol,pmid, temperature) !smb--sectional @@ -791,10 +791,10 @@ end subroutine coagtend_sec -subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) +subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) -! Calculate the coagulation of small aerosols with larger particles and -! cloud droplets. Only particles smaller that dry radius of +! Calculate the coagulation of small aerosols with larger particles and +! cloud droplets. Only particles smaller that dry radius of ! 40 nm is assumed to have an efficient coagulation with other particles. use shr_kind_mod, only: r8 => shr_kind_r8 @@ -805,7 +805,7 @@ subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) use physics_buffer, only : physics_buffer_desc use modal_aero_data, only : qqcw_get_field implicit none - + ! input arguments integer, intent(in) :: ncol ! number of horizontal grid cells (columns) @@ -828,7 +828,7 @@ subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) integer :: modeIndexCoagulator !Index of coagulating mode integer :: modeIndexReceiver !Index of receiving mode real(r8) :: rhoAir ![kg/m3] air density - real(r8) :: coagulationSink ![1/s] loss for coagulating specie + real(r8) :: coagulationSink ![1/s] loss for coagulating specie real(r8), dimension(numberOfCoagulationReceivers):: numberConcentration ![#/m3] number concentration real(r8) :: totalLoss(pcols,pver,gas_pcnst) ![kg/kg] tracer lost character(128) :: long_name ![-] needed for diagnostics @@ -844,11 +844,11 @@ subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) call phys_getopts(history_aerosol_out = history_aerosol) do k=1,pver - do i=1,ncol - + do i=1,ncol + !Air density rhoAir = pmid(i,k)/rair/temperature(i,k) - + !Initialize number concentration for all receivers numberConcentration(:) = 0.0_r8 @@ -869,7 +869,7 @@ subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) numberConcentration(iReceiver) = numberConcentration(iReceiver) & !previous value + q(i,k,l_index_receiver) & !kg/kg / rhopart(physicsIndex(l_index_receiver)) & !*[m3/kg] ==> m3/kg - * volumeToNumber(receiverMode(ireceiver)) & ![#/m3] ==> #/kg + * volumeToNumber(receiverMode(ireceiver)) & ![#/m3] ==> #/kg * rhoAir !#/kg ==> #/m3 end if end do !Lifecycle "core" species in this mode @@ -886,16 +886,16 @@ subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) !Sum the loss for all possible receivers do iReceiver = 1, numberOfCoagulationReceivers - + modeIndexReceiver = receiverMode(iReceiver) !Sum up coagulation sink for this coagulating species (for all receiving modes) coagulationSink = & ![1/s] coagulationSink + & ![1/] previous value - normalizedCoagulationSink(modeIndexReceiver, modeIndexCoagulator) & ![m3/#/s] + normalizedCoagulationSink(modeIndexReceiver, modeIndexCoagulator) & ![m3/#/s] * numberConcentration(ireceiver) !numberConcentration (#/m3) end do !receiver modes - + !SOME LIFECYCLE SPECIES CHANGE "HOST MODE" WHEN THEY PARTICIPATE !IN COAGULATION (THEY GO FROM EXTERNALLY MIXED TO INTERNALLY MIXED MODES) @@ -909,8 +909,8 @@ subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) !process modes don't change mode except so4 condensate which becomes coagulate instead !assumed to have same sink as MODE_IDX_OMBC_INTMIX_AIT - if( .NOT. is_process_mode(l_index_donor,.true.) & - .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. modeIndexCoagulator .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then + if( .NOT. is_process_mode(l_index_donor,.true.) & + .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. modeIndexCoagulator .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then !Done summing total loss of this coagulating specie totalLoss(i,k,l_index_donor) = coagulationSink & !loss rate for a mode in [1/s] summed over all receivers @@ -937,12 +937,12 @@ subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) !so4_a1 is a process mode (condensate), but is still lost in coagulation if( .NOT. is_process_mode(l_index_donor, .true.) & - .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. coagulatingMode(iCoagulator) .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then + .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. coagulatingMode(iCoagulator) .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then l_index_donor = getTracerIndex(coagulatingMode(iCoagulator) , ispecie,.true. ) !index of mode gaining mass (l_so4_ac, l_om_ac, l_bc_ac), coagulate - l_index_receiver = lifeCycleReceiver(l_index_donor) + l_index_receiver = lifeCycleReceiver(l_index_donor) do k=1,pver !Loose mass from tracer in donor mode @@ -958,13 +958,13 @@ subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) !Output for diagnostics if(history_aerosol)then coltend(:ncol,:) = 0.0_r8 - do i=1,gas_pcnst + do i=1,gas_pcnst !Check if species contributes to coagulation if(lifeCycleReceiver(i) .gt. 0)then !Loss from the donor specie tracer_coltend(:ncol) = sum(totalLoss(:ncol, :,i)*pdel(:ncol,:),2)/gravit*delt_inverse coltend(:ncol,i) = coltend(:ncol,i) - tracer_coltend(:ncol) !negative, loss for donor - coltend(:ncol,lifeCycleReceiver(i)) = coltend(:ncol,lifeCycleReceiver(i)) + tracer_coltend(:ncol) + coltend(:ncol,lifeCycleReceiver(i)) = coltend(:ncol,lifeCycleReceiver(i)) + tracer_coltend(:ncol) endif end do do i=1,gas_pcnst @@ -979,10 +979,10 @@ subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) end subroutine coagtend -subroutine clcoag( q, pmid, pdel, temperature, cldnum, cldfrc, delt_inverse, ncol , lchnk, im, pbuf) +subroutine clcoag( q, pmid, pdel, temperature, cldnum, cldfrc, delt_inverse, ncol , lchnk, im, pbuf) -! Calculate the coagulation of small aerosols with larger particles and -! cloud droplets. Only particles smaller that dry radius of +! Calculate the coagulation of small aerosols with larger particles and +! cloud droplets. Only particles smaller that dry radius of ! 40 nm is assumed to have an efficient coagulation with other particles. use shr_kind_mod, only: r8 => shr_kind_r8 @@ -993,17 +993,17 @@ subroutine clcoag( q, pmid, pdel, temperature, cldnum, cldfrc, delt_inverse, nc use physics_buffer, only : physics_buffer_desc use modal_aero_data, only : qqcw_get_field implicit none - + ! input arguments integer, intent(in) :: ncol ! number of horizontal grid cells (columns) - real(r8), intent(inout) :: q(pcols,pver,gas_pcnst) ! TMR [kg/kg] including moisture - real(r8), intent(in) :: pmid(pcols,pver) ! [Pa] midpoint pressure - real(r8), intent(in) :: pdel(pcols,pver) - real(r8), intent(in) :: temperature(pcols,pver) ! [K] temperature + real(r8), intent(inout) :: q(:,:,:) ! TMR [kg/kg] including moisture + real(r8), intent(in) :: pmid(:,:) ! [Pa] midpoint pressure + real(r8), intent(in) :: pdel(:,:) + real(r8), intent(in) :: temperature(:,:) ! [K] temperature - real(r8), dimension(ncol,pver),intent(in) :: cldnum ! Droplet concentration #/kg - real(r8), dimension(ncol,pver),intent(in) :: cldfrc ! Cloud volume fraction + real(r8), dimension(:,:),intent(in) :: cldnum ! Droplet concentration #/kg + real(r8), dimension(:,:),intent(in) :: cldfrc ! Cloud volume fraction real(r8), intent(in) :: delt_inverse ! [1/s] inverse time step integer, intent(in) :: lchnk ! [] chnk id needed for output @@ -1024,7 +1024,7 @@ subroutine clcoag( q, pmid, pdel, temperature, cldnum, cldfrc, delt_inverse, nc integer :: l_index_donor integer :: modeIndexCoagulator !Index of coagulating mode integer :: modeIndexReceiver !Index of receiving mode - real(r8) :: coagulationSink ![1/s] loss for coagulating specie + real(r8) :: coagulationSink ![1/s] loss for coagulating specie real(r8), dimension(numberOfCoagulationReceivers):: numberConcentration ![#/m3] number concentration real(r8) :: cloudLoss(pcols,pver,gas_pcnst) ![kg/kg] tracer lost character(128) :: long_name ![-] needed for diagnostics @@ -1041,7 +1041,7 @@ subroutine clcoag( q, pmid, pdel, temperature, cldnum, cldfrc, delt_inverse, nc do k=1,pver - do i=1,ncol + do i=1,ncol if (cldfrc(i,k).gt.1.e-2) then rhoAir = pmid(i,k)/rair/temperature(i,k) !Go through all coagulating modes @@ -1057,9 +1057,9 @@ subroutine clcoag( q, pmid, pdel, temperature, cldnum, cldfrc, delt_inverse, nc !Sum up coagulation sink for this coagulating species (for all receiving modes) coagulationSink = & ![1/s] - NCloudCoagulationSink(modeIndexCoagulator) & ![m3/#/s] + NCloudCoagulationSink(modeIndexCoagulator) & ![m3/#/s] * (rhoair*cldnum(i,k)/cldfrc(i,k)) ![kg/m3*#/kg - + !Each coagulating mode can contain several species do ispecie = 1, getNumberOfTracersInMode(modeIndexCoagulator) @@ -1070,24 +1070,24 @@ subroutine clcoag( q, pmid, pdel, temperature, cldnum, cldfrc, delt_inverse, nc !process modes don't change mode except so4 condensate which becomes coagulate instead !assumed to have same sink as MODE_IDX_OMBC_INTMIX_AIT - if( .NOT. is_process_mode(l_index_donor,.true.) & - .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. modeIndexCoagulator .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then + if( .NOT. is_process_mode(l_index_donor,.true.) & + .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. modeIndexCoagulator .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then !Done summing total loss of this coagulating specie cloudLoss(i,k,l_index_donor) = coagulationSink & !loss rate for a mode in [1/s] summed over all receivers * cldfrc(i,k)*q(i,k,l_index_donor) & !* mixing ratio ==> MMR/s / delt_inverse ! seconds ==> MMR - !Can not loose more than we have + !Can not loose more than we have ! At present day assumed lost within the cloud cloudLoss(i,k,l_index_donor) = min(cloudLoss(i,k,l_index_donor) , cldfrc(i,k)*q(i,k,l_index_donor)) - + end if !check on process modes end do !species in mode - + end do !coagulator mode - end if ! cldfrc .gt. 0.01 + end if ! cldfrc .gt. 0.01 end do ! i end do ! k @@ -1099,12 +1099,12 @@ subroutine clcoag( q, pmid, pdel, temperature, cldnum, cldfrc, delt_inverse, nc !so4_a1 is a process mode (condensate), but is still lost in coagulation if( .NOT. is_process_mode(l_index_donor, .true.) & - .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. coagulatingMode(iCoagulator) .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then + .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. coagulatingMode(iCoagulator) .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then l_index_donor = getTracerIndex(coagulatingMode(iCoagulator) , ispecie,.true. ) !index of mode gaining mass (l_so4_a2, l_om_ac, l_bc_ac), coagulate - l_index_receiver = CloudAerReceiver(l_index_donor) + l_index_receiver = CloudAerReceiver(l_index_donor) fldcw => qqcw_get_field(pbuf, CloudAerReceiver(l_index_donor)+im,lchnk,errorhandle=.true.) do k=1,pver !Loose mass from tracer in donor mode @@ -1112,24 +1112,24 @@ subroutine clcoag( q, pmid, pdel, temperature, cldnum, cldfrc, delt_inverse, nc !Give mass to tracer in receiver mode if(associated(fldcw)) then fldcw(:ncol,k) = fldcw(:ncol,k) + cloudLoss(:ncol,k,l_index_donor) - end if + end if end do !k endif end do - end do + end do !Output for diagnostics if(history_aerosol)then coltend(:ncol,:) = 0.0_r8 - do i=1,gas_pcnst + do i=1,gas_pcnst !Check if species contributes to coagulation if(CloudAerReceiver(i) .gt. 0)then !Loss from the donor specie tracer_coltend(:ncol) = sum(cloudLoss(:ncol, :,i)*pdel(:ncol,:),2)/gravit*delt_inverse coltend(:ncol,i) = coltend(:ncol,i) - tracer_coltend(:ncol) !negative, loss for donor - coltend(:ncol,CloudAerReceiver(i)) = coltend(:ncol,CloudAerReceiver(i)) + tracer_coltend(:ncol) + coltend(:ncol,CloudAerReceiver(i)) = coltend(:ncol,CloudAerReceiver(i)) + tracer_coltend(:ncol) endif end do do i=1,gas_pcnst @@ -1174,9 +1174,9 @@ function calculateParticleDiffusivity(radius) result (diffusivity) knudsenNumber = mfpAir/radius - factor = (kboltzmann*temperatureLookupTables/3.0_r8/pi/viscosityAir/2.0_r8/radius) + factor = (kboltzmann*temperatureLookupTables/3.0_r8/pi/viscosityAir/2.0_r8/radius) numerator = 5.0_r8 + 4.0_r8*knudsenNumber + 6.0_r8*knudsenNumber**2 + 18.0_r8*knudsenNumber**3 - nominator = 5.0_r8 - knudsenNumber + (8.0_r8 + pi)*knudsenNumber**2 + nominator = 5.0_r8 - knudsenNumber + (8.0_r8 + pi)*knudsenNumber**2 diffusivity = factor*numerator/nominator end function calculateParticleDiffusivity diff --git a/src/chemistry/oslo_aero_sec/ndrop.F90 b/src/chemistry/oslo_aero_sec/ndrop.F90 index 1db290295e..b61cc85946 100644 --- a/src/chemistry/oslo_aero_sec/ndrop.F90 +++ b/src/chemistry/oslo_aero_sec/ndrop.F90 @@ -628,7 +628,19 @@ subroutine dropmixnuc( & character(len=2) :: modeString character(len=20) :: varname #endif - integer :: numberOfModes + integer :: numberOfModes + integer :: modtype(nmodes) + real(r8) :: sigi(nmodes) + real(r8) :: A,B,ACCOM + real(r8) :: SG(nmodes) + real(r8) :: press + real(r8) :: DPGI(nmodes) + real(r8) :: NDACT + real(r8) :: SMAX + real(r8) :: suma + integer :: mk + real(r8) :: actfrac(nmodes) + real(r8) :: mactfrac(nmodes) !------------------------------------------------------------------------------- #undef EXTRATESTS #undef MASS_BALANCE_CHECK @@ -808,7 +820,12 @@ subroutine dropmixnuc( & !end do !stop endif - +! fn(:) = 0.0_r8 +! fm(:) = 0.0_r8 +! fluxn(:)=0.0_r8 +! fluxm(:)= 0.0_r8 +! fn_in(:,:,:)=0.0_r8 +! flux_fullact(:)=0.0_r8 ! Need to be set if using alternative activation formulation. #endif ! overall_main_i_loop @@ -1132,10 +1149,13 @@ subroutine dropmixnuc( & ! load aerosol properties, assuming external mixtures #ifdef OSLO_AERO + naermod(:) = 0.0_r8 vaerosol(:) = 0.0_r8 hygro(:) = 0.0_r8 lnsigman(:) = log(2.0_r8) + actfrac(:) = 0.0_r8 + mactfrac(:) = 0.0_r8 m=0 do kcomp = 1,nmodes @@ -1144,11 +1164,75 @@ subroutine dropmixnuc( & naermod(m) = numberConcentration(i,k,kcomp) vaerosol(m) = volumeConcentration(i,k,kcomp) hygro(m) = hygroscopicity(i,k,kcomp) + hygro(m) = max(hygro(m),0.01_r8) lnsigman(m) = lnsigma(i,k,kcomp) speciesMap(m) = kcomp + modtype(m)=1 + sigi(m)=exp(lnsigman(m)) +! write(6,*) 'ndrop ',m,lnsigman(m),sigi(m) + SG(m)=0.0_r8 +! exp45logsig_var(m) = exp(4.5_r8*lnsigman(m)*lnsigman(m)) +! amcube(m)=(3._r8*volume(m)/(4._r8*pi*exp45logsig_var(m)*na(m))) ! only if variable size dist +! radius(m)=amcube(m)**(1._r8/3._r8) + DPGI(m)=2._r8*numberMedianRadius(i,k,kcomp) end if end do numberOfModes = m + A=2.25_r8 + B=1.2_r8 + ACCOM=1.0_r8 ! Can be reduced to 0.1, 0.042 (Prup + + press=287._r8*cs(i,k)*temp(i,k) + +! open(unit=667, file='stuffxxx', access='append', status='unknown') +! write(667,*) 'before access1' +! close(667) + CALL CCNSPEC (naermod,DPGI,sigi,modtype,temp(i,k),press,numberOfModes,hygro,A,B,SG) + +! WPARC = wbar ! Vertical velocity (m/s) +! SIGW = wmix +! fn + CALL PDFACTIV (wbar,naermod,hygro,A,B,ACCOM,SG,wmix,temp(i,k),press,NDACT,actfrac,mactfrac,numberOfModes,SMAX) +! suma=0._r8 +! do mk=1,numberOfModes +! suma=suma+naermod(mk)*actfrac(mk) +! end do +! WRITE(97,*) NDACT*1.d-6, suma*1.d-6,SMAX*100.d0, wbar,wmix +! write(99,*) +! WRITE (99,*) ' ',naermod, DPGI, SIGI, hygro, temp(i,k), press, numberofmodes, wbar,ndact, smax +! do m=1,numberOfModes +! write(6,*) 'loop1 ',i,k,m,actfrac(m),mactfrac(m) +! actfrac(m)=0.90_r8 +! mactfrac(m)=0.90_r8 +! end do + if (use_hetfrz_classnuc) then + fn_in(i,k,1:nmodes)=0.0_r8 + else + fn(m)=0.0_r8 + end if +! fn_in(i,k,1:nmodes)=0._r8 + fm(:)=0._r8 + fluxn(:)=0._r8 + fluxm(:)=0._r8 + flux_fullact(k)=0._r8 + do m=1,numberOfModes + if (use_hetfrz_classnuc) then + fn_in(i,k,m)=actfrac(m) + else + fn(m)=actfrac(m) + end if + fm(m)=mactfrac(m) + if(wbar.gt.0._r8)then + fluxn(m)=actfrac(m)*wbar + fluxm(m)=mactfrac(m)*wbar + + else + fluxn(m)=0._r8 + fluxm(m)=0._r8 + endif + end do + if (wbar.gt.0.0_r8) & + flux_fullact(k)=wbar #else numberOfModes = ntot_amode phase = 1 ! interstitial @@ -1164,35 +1248,35 @@ subroutine dropmixnuc( & #endif !++ MH_2015/04/10 !Call the activation procedure - if(numberOfModes .gt. 0)then - if (use_hetfrz_classnuc) then - call activate_modal( & - wbar, wmix, wdiab, wmin, wmax, & - temp(i,k), cs(i,k), naermod, numberOfModes, & - vaerosol, hygro, fn_in(i,k,1:nmodes), fm, fluxn, & - fluxm,flux_fullact(k) & -#ifdef OSLO_AERO - ,lnsigman & -#endif - ) - else - call activate_modal( & - wbar, wmix, wdiab, wmin, wmax, & - temp(i,k), cs(i,k), naermod, numberOfModes, & - vaerosol, hygro, fn, fm, fluxn, & - fluxm,flux_fullact(k) & -#ifdef OSLO_AERO - ,lnsigman & -#endif - ) - end if +! if(numberOfModes .gt. 0)then +! if (use_hetfrz_classnuc) then +! call activate_modal( &nc +! wbar, wmix, wdiab, wmin, wmax, & +! temp(i,k), cs(i,k), naermod, numberOfModes, & +! vaerosol, hygro, fn_in(i,k,1:nmodes), fm, fluxn, & +! fluxm,flux_fullact(k) & +!#ifdef OSLO_AERO +! ,lnsigman & +!#endif +! ) +! else +! call activate_modal( & +! wbar, wmix, wdiab, wmin, wmax, & +! temp(i,k), cs(i,k), naermod, numberOfModes, & +! vaerosol, hygro, fn, fm, fluxn, & +! fluxm,flux_fullact(k) & +!#ifdef OSLO_AERO +! ,lnsigman & +!#endif +! ) +! end if !-- MH_2015/04/10 - endif +! endif dumc = (cldn_tmp - cldo_tmp) #ifdef OSLO_AERO if (use_hetfrz_classnuc) then - fn_tmp(:) = fn_in(i,k,1:nmodes) + fn_tmp(:) = fn_in(i,k,1:nmodes) else fn_tmp(:) = fn(:) end if @@ -1200,7 +1284,7 @@ subroutine dropmixnuc( & fluxn_tmp(:) = fluxn(:) fluxm_tmp(:) = fluxm(:) fn(:) = 0.0_r8 - fn_in(i,k,:) = 0.0_r8 + fn_in(i,k,:) = 0.0_r8 fm(:) = 0.0_r8 fluxn(:)=0.0_r8 fluxm(:)= 0.0_r8 @@ -1214,7 +1298,11 @@ subroutine dropmixnuc( & fm(kcomp) = fm_tmp(m) fluxn(kcomp) = fluxn_tmp(m) fluxm(kcomp) = fluxm_tmp(m) +! if (use_hetfrz_classnuc) then +! write(6,*) 'loop1 ',m,kcomp,wbar,fm(kcomp),fn_in(i,k,kcomp),fluxm(kcomp) +! end if enddo + #endif do m = 1, ntot_amode mm = mam_idx(m,0) @@ -1313,7 +1401,8 @@ subroutine dropmixnuc( & vaerosol(:) = 0.0_r8 hygro(:) = 0.0_r8 lnsigman(:) = log(2.0_r8) - + actfrac(:) = 0.0_r8 + mactfrac(:) = 0.0_r8 m=0 do kcomp = 1,nmodes if(hasAerosol(i,kp1,kcomp) .eqv. .TRUE.)then @@ -1321,11 +1410,76 @@ subroutine dropmixnuc( & naermod(m) = numberConcentration(i,kp1,kcomp) vaerosol(m) = volumeConcentration(i,kp1,kcomp) hygro(m) = hygroscopicity(i,kp1,kcomp) + hygro(m) = max(hygro(m),0.01_r8) lnsigman(m) = lnsigma(i,kp1,kcomp) speciesMap(m) = kcomp + modtype(m)=1 + sigi(m)=exp(lnsigman(m)) +! write(6,*) 'ndrop ',m,lnsigman(m),sigi(m) + SG(m)=0.0_r8 +! exp45logsig_var(m) = exp(4.5_r8*lnsigman(m)*lnsigman(m)) +! amcube(m)=(3._r8*volume(m)/(4._r8*pi*exp45logsig_var(m)*na(m))) ! only if variable size dist +! radius(m)=amcube(m)**(1._r8/3._r8) + DPGI(m)=2._r8*numberMedianRadius(i,k,kcomp) end if end do numberOfModes = m + + A=2.25_r8 + B=1.2_r8 + ACCOM=1.0_r8 + + press=287._r8*cs(i,k)*temp(i,k) +! open(unit=667, file='stuffxxx', access='append', status='unknown') +! write(667,*) 'before access2' +! close(667) + CALL CCNSPEC (naermod,DPGI,sigi,modtype,temp(i,k),press,numberOfModes,hygro,A,B,SG) + +! WPARC = wbar ! Vertical velocity (m/s) +! SIGW = wmix +! fn + CALL PDFACTIV (wbar,naermod,hygro,A,B,ACCOM,SG,wmix,temp(i,k),press,NDACT,actfrac,mactfrac,numberOfModes,SMAX) +! suma=0._r8 +! do mk=1,numberOfModes +! suma=suma+naermod(mk)*fn_in(i,k,mk) +! end do +! WRITE(97,*) NDACT*1.d-6, suma*1.d-6,SMAX*100.d0, wbar,wmix +! write(99,*) +! WRITE (99,*) ' ',naermod, DPGI, SIGI, hygro, temp(i,k), press, numberofmodes, wbar,ndact, smax + +!do m=1,numberofModes +! write(6,*) 'loop2 ',i,k,m,actfrac(m),mactfrac(m) +! actfrac(m)=0.90_r8 +! mactfrac(m)=0.90_r8 + +! end do + if (use_hetfrz_classnuc) then + fn_in(i,k,1:nmodes)=0.0_r8 + else + fn(m)=0.0_r8 + end if +! fn_in(i,k,1:nmodes)=0._r8 + fm(:)=0._r8 + fluxn(:)=0._r8 + fluxm(:)=0._r8 + flux_fullact(k)=0._r8 + do m=1,numberOfModes + if (use_hetfrz_classnuc) then + fn_in(i,k,m)=actfrac(m) + else + fn(m)=actfrac(m) + end if + fm(m)=mactfrac(m) + if(wbar.gt.0._r8)then + fluxn(m)=actfrac(m)*wbar + fluxm(m)=mactfrac(m)*wbar + else + fluxn(m)=0._r8 + fluxm(m)=0._r8 + endif + end do + if (wbar.gt.0.0_r8) & + flux_fullact(k)=wbar #else numberOfModes = ntot_amode @@ -1339,33 +1493,33 @@ subroutine dropmixnuc( & naermod(m) = na(i) vaerosol(m) = va(i) hygro(m) = hy(i) - end do + end do #endif !++ MH_2015/04/10 - if(numberOfModes .gt. 0)then - if (use_hetfrz_classnuc) then - call activate_modal( & - wbar, wmix, wdiab, wmin, wmax, & - temp(i,k), cs(i,k), naermod, numberOfModes , & - vaerosol, hygro, fn_in(i,k,:), fm, fluxn, & - fluxm, flux_fullact(k) & -#ifdef OSLO_AERO - ,lnsigman & -#endif - ) - else - call activate_modal( & - wbar, wmix, wdiab, wmin, wmax, & - temp(i,k), cs(i,k), naermod, numberOfModes , & - vaerosol, hygro, fn, fm, fluxn, & - fluxm, flux_fullact(k) & -#ifdef OSLO_AERO - ,lnsigman & -#endif - ) - end if +! if(numberOfModes .gt. 0)then +! if (use_hetfrz_classnuc) then +! call activate_modal( & +! wbar, wmix, wdiab, wmin, wmax, & +! temp(i,k), cs(i,k), naermod, numberOfModes , & +! vaerosol, hygro, fn_in(i,k,1:nmodes), fm, fluxn, & +! fluxm, flux_fullact(k) & +!#ifdef OSLO_AERO +! ,lnsigman & +!#endif +! ) +! else +! call activate_modal( & +! wbar, wmix, wdiab, wmin, wmax, & +! temp(i,k), cs(i,k), naermod, numberOfModes , & +! vaerosol, hygro, fn, fm, fluxn, & +! fluxm, flux_fullact(k) & +!#ifdef OSLO_AERO +! ,lnsigman & +!#endif +! ) +! end if !-- MH_2015/04/10 - endif +! endif !Difference in cloud fraction this layer and above! !we are here because there are more clouds above, and some @@ -1377,32 +1531,33 @@ subroutine dropmixnuc( & endif #ifdef OSLO_AERO - if (use_hetfrz_classnuc) then - fn_tmp(:) = fn_in(i,k,1:nmodes) - else - fn_tmp(:) = fn(:) - end if - fm_tmp(:) = fm(:) - fluxn_tmp(:) = fluxn(:) - fluxm_tmp(:) = fluxm(:) - fn(:) = 0.0_r8 - fn_in(i,k,:) = 0.0_r8 - fm(:) = 0.0_r8 - fluxn(:)=0.0_r8 - fluxm(:)= 0.0_r8 - do m = 1, numberOfModes !Number of coexisting modes to be used for activation - kcomp = speciesMap(m) !This is the CAM-oslo mode (modes 1-14 may be activated, mode 0 not) - if (use_hetfrz_classnuc) then - fn_in(i,k,kcomp) = fn_tmp(m) - else - fn(kcomp) = fn_tmp(m) - end if - fm(kcomp) = fm_tmp(m) - fluxn(kcomp) = fluxn_tmp(m) - fluxm(kcomp) = fluxm_tmp(m) - enddo -#endif + if (use_hetfrz_classnuc) then + fn_tmp(:) = fn_in(i,k,1:nmodes) + else + fn_tmp(:) = fn(:) + end if + fm_tmp(:) = fm(:) + fluxn_tmp(:) = fluxn(:) + fluxm_tmp(:) = fluxm(:) + fn(:) = 0.0_r8 + fn_in(i,k,:) = 0.0_r8 + fm(:) = 0.0_r8 + fluxn(:)=0.0_r8 + fluxm(:)= 0.0_r8 + do m = 1, numberOfModes !Number of coexisting modes to be used for activation + kcomp = speciesMap(m) !This is the CAM-oslo mode (modes 1-14 may be activated, mode 0 not) + if (use_hetfrz_classnuc) then + fn_in(i,k,kcomp) = fn_tmp(m) + else + fn(kcomp) = fn_tmp(m) + end if + fm(kcomp) = fm_tmp(m) + fluxn(kcomp) = fluxn_tmp(m) + fluxm(kcomp) = fluxm_tmp(m) +! write(6,*) 'loop2 ',m,kcomp,wbar,fm(kcomp),fn_in(i,k,kcomp),fluxm(kcomp) + enddo +#endif fluxntot = 0.0_r8 ! rce-comment 1 diff --git a/src/chemistry/pp_trop_mam_oslo_sec/chem_mech.doc b/src/chemistry/pp_trop_mam_oslo_sec/chem_mech.doc index 97f0833610..5da600dfc6 100644 --- a/src/chemistry/pp_trop_mam_oslo_sec/chem_mech.doc +++ b/src/chemistry/pp_trop_mam_oslo_sec/chem_mech.doc @@ -118,9 +118,9 @@ Class List ( 7) monoterp + O3 -> .15*SOA_LV rate = 8.05E-16*exp( -640./t) ( 8) ( 8) monoterp + OH -> .15*SOA_SV rate = 1.20E-11*exp( 440./t) ( 9) ( 9) monoterp + NO3 -> .15*SOA_SV rate = 1.20E-12*exp( 490./t) ( 10) - ( 10) isoprene + O3 -> .05*SOA_SV rate = 1.03E-14*exp( -1995./t) ( 11) - ( 11) isoprene + OH -> .05*SOA_SV rate = 2.70E-11*exp( 390./t) ( 12) - ( 12) isoprene + NO3 -> .05*SOA_SV rate = 3.15E-12*exp( -450./t) ( 13) + ( 10) isoprene + O3 -> .005*SOA_SV rate = 1.03E-14*exp( -1995./t) ( 11) + ( 11) isoprene + OH -> .005*SOA_SV rate = 2.70E-11*exp( 390./t) ( 12) + ( 12) isoprene + NO3 -> .005*SOA_SV rate = 3.15E-12*exp( -450./t) ( 13) Heterogeneous loss species @@ -164,8 +164,8 @@ Extraneous prod/loss species d(SOA_NA)/dt = 0 d(SOA_A1)/dt = 0 d(SOA_LV)/dt = .029*r6*OH*DMS + .15*r7*O3*monoterp - d(SOA_SV)/dt = .114*r6*OH*DMS + .15*r8*OH*monoterp + .15*r9*NO3*monoterp + .05*r10*O3*isoprene - + .05*r11*OH*isoprene + .05*r12*NO3*isoprene + d(SOA_SV)/dt = .114*r6*OH*DMS + .15*r8*OH*monoterp + .15*r9*NO3*monoterp + .005*r10*O3*isoprene + + .005*r11*OH*isoprene + .005*r12*NO3*isoprene d(SOA_SEC01)/dt = 0 d(SOA_SEC02)/dt = 0 d(SOA_SEC03)/dt = 0 diff --git a/src/chemistry/pp_trop_mam_oslo_sec/chem_mech.in b/src/chemistry/pp_trop_mam_oslo_sec/chem_mech.in index dd76dccdb3..e755989c6b 100644 --- a/src/chemistry/pp_trop_mam_oslo_sec/chem_mech.in +++ b/src/chemistry/pp_trop_mam_oslo_sec/chem_mech.in @@ -1,4 +1,3 @@ -BEGSIM SPECIES Solution @@ -85,9 +84,9 @@ BEGSIM monoterp + O3 -> .15*SOA_LV ; 8.05e-16, -640. monoterp + OH -> .15*SOA_SV ; 1.2e-11, 440. monoterp + NO3 -> .15*SOA_SV ; 1.2e-12, 490. - isoprene + O3 -> .05*SOA_SV ; 1.03e-14, -1995. - isoprene + OH -> .05*SOA_SV ; 2.7e-11, 390. - isoprene + NO3 -> .05*SOA_SV ; 3.15e-12, -450. + isoprene + O3 -> .005*SOA_SV ; 1.03e-14, -1995. + isoprene + OH -> .005*SOA_SV ; 2.7e-11, 390. + isoprene + NO3 -> .005*SOA_SV ; 3.15e-12, -450. End Reactions Heterogeneous @@ -119,4 +118,3 @@ BEGSIM End Version Options END SIMULATION PARAMETERS -ENDSIM diff --git a/src/chemistry/pp_trop_mam_oslo_sec/mo_lin_matrix.F90 b/src/chemistry/pp_trop_mam_oslo_sec/mo_lin_matrix.F90 index dfc9c2572b..e458f9d28a 100644 --- a/src/chemistry/pp_trop_mam_oslo_sec/mo_lin_matrix.F90 +++ b/src/chemistry/pp_trop_mam_oslo_sec/mo_lin_matrix.F90 @@ -49,7 +49,7 @@ subroutine linmat01( mat, y, rxt, het_rates ) mat(32) = -( het_rates(27) ) mat(4) = .114_r8*rxt(7) mat(34) = .150_r8*rxt(9) + .150_r8*rxt(10) - mat(36) = .050_r8*rxt(11) + .050_r8*rxt(12) + .050_r8*rxt(13) + mat(36) = .005_r8*rxt(11) + .005_r8*rxt(12) + .005_r8*rxt(13) mat(35) = -( rxt(8) + rxt(9) + rxt(10) + het_rates(38) ) mat(37) = -( rxt(11) + rxt(12) + rxt(13) + het_rates(39) ) mat(38) = -( het_rates(28) ) diff --git a/src/chemistry/pp_trop_mam_oslo_sec/mo_prod_loss.F90 b/src/chemistry/pp_trop_mam_oslo_sec/mo_prod_loss.F90 index adbdac9ac3..c92722f15b 100644 --- a/src/chemistry/pp_trop_mam_oslo_sec/mo_prod_loss.F90 +++ b/src/chemistry/pp_trop_mam_oslo_sec/mo_prod_loss.F90 @@ -85,7 +85,7 @@ subroutine imp_prod_loss( prod, loss, y, rxt, het_rates ) loss(26) = ( + het_rates(26))* y(26) prod(26) =.029_r8*rxt(7)*y(3) +.150_r8*rxt(8)*y(38) loss(27) = ( + het_rates(27))* y(27) - prod(27) = (.050_r8*rxt(11) +.050_r8*rxt(12) +.050_r8*rxt(13))*y(39) & + prod(27) = (.005_r8*rxt(11) +.005_r8*rxt(12) +.005_r8*rxt(13))*y(39) & + (.150_r8*rxt(9) +.150_r8*rxt(10))*y(38) +.114_r8*rxt(7)*y(3) loss(28) = ( + rxt(8) + rxt(9) + rxt(10) + het_rates(38))* y(38) prod(28) = 0._r8 diff --git a/src/control/runtime_opts.F90 b/src/control/runtime_opts.F90 index 53b36d061f..dadd7e3b16 100644 --- a/src/control/runtime_opts.F90 +++ b/src/control/runtime_opts.F90 @@ -39,7 +39,8 @@ subroutine read_namelist(nlfilename, single_column, scmlat, scmlon) use physics_buffer, only: pbuf_readnl use phys_control, only: phys_ctl_readnl #ifdef OSLO_AERO - use oslo_control, only: oslo_ctl_readnl + use oslo_control, only: oslo_ctl_readnl + use module_random_forests,only: sec_ice_readnl #endif use wv_saturation, only: wv_sat_readnl use ref_pres, only: ref_pres_readnl @@ -185,6 +186,7 @@ subroutine read_namelist(nlfilename, single_column, scmlat, scmlon) #endif #if (defined OSLO_AERO) call oslo_ctl_readnl(nlfilename) + call sec_ice_readnl(nlfilename) #endif call offline_driver_readnl(nlfilename) call analytic_ic_readnl(nlfilename)